diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for fnotation + +## 0.1.0.0 -- 2026-03-30 + +* Basics in place. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/fnotation.cabal b/fnotation.cabal new file mode 100644 --- /dev/null +++ b/fnotation.cabal @@ -0,0 +1,69 @@ +cabal-version: 3.4 +name: fnotation +description: A lower house syntax for programming language experimentation. +version: 0.1.0.0 +license: MPL-2.0 +license-file: LICENSE +maintainer: root@owenlynch.org +author: Owen Lynch +category: Language +build-type: Simple +extra-doc-files: CHANGELOG.md + +library + exposed-modules: + FNotation + FNotation.Config + FNotation.Lexer + FNotation.Names + FNotation.Parser + FNotation.Pretty + FNotation.Tokens + FNotation.Trees + + hs-source-dirs: src + default-language: GHC2024 + default-extensions: + BlockArguments CPP TypeData DerivingVia FunctionalDependencies + ImplicitParams MagicHash NoFieldSelectors OrPatterns + OverloadedRecordDot OverloadedStrings PatternSynonyms QualifiedDo + StrictData TypeFamilies TypeFamilyDependencies UnboxedSums + UnboxedTuples UnicodeSyntax ViewPatterns + + ghc-options: -Wall + build-depends: + base ^>=4.21.0.0, + containers, + diagnostician, + hashable, + prettyprinter, + text, + vector, + vector-hashtables >=0.1.2.1 + +test-suite fnotation-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + BlockArguments CPP TypeData DerivingVia FunctionalDependencies + MagicHash NoFieldSelectors OrPatterns OverloadedRecordDot + OverloadedStrings PatternSynonyms QualifiedDo StrictData + TypeFamilies TypeFamilyDependencies UnboxedSums UnboxedTuples + UnicodeSyntax ViewPatterns + + ghc-options: -Wall -Wno-unused-imports + build-depends: + base ^>=4.21.0.0, + bytestring, + containers, + diagnostician, + filepath, + fnotation, + prettyprinter, + tasty, + tasty-golden, + temporary, + text, + vector diff --git a/src/FNotation.hs b/src/FNotation.hs new file mode 100644 --- /dev/null +++ b/src/FNotation.hs @@ -0,0 +1,18 @@ +module FNotation + ( module FNotation.Config, + module FNotation.Lexer, + module FNotation.Names, + module FNotation.Parser, + module FNotation.Pretty, + module FNotation.Tokens, + module FNotation.Trees, + ) +where + +import FNotation.Config +import FNotation.Lexer (LexerCode (..), lex, lexerCodeTable) +import FNotation.Names +import FNotation.Parser (ParserCode (..), parse, parserCodeTable) +import FNotation.Pretty (dprettyWithPrecs) +import FNotation.Tokens (Kind) +import FNotation.Trees (Ntn, Ntn0, NtnGeneric (..), head, span) diff --git a/src/FNotation/Config.hs b/src/FNotation/Config.hs new file mode 100644 --- /dev/null +++ b/src/FNotation/Config.hs @@ -0,0 +1,38 @@ +module FNotation.Config where + +import Data.Text +import Data.Vector.Hashtables (FrozenDictionary) +import Data.Vector.Hashtables qualified as HT +import Data.Vector.Strict qualified as V +import System.IO.Unsafe (unsafePerformIO) + +newtype ConfTable a = ConfTable (FrozenDictionary V.Vector Text V.Vector a) + +confTableLookup :: ConfTable a -> Text -> Maybe a +confTableLookup (ConfTable d) x = case HT.findElem d x of + -1 -> Nothing + i -> Just (HT.fvalue d V.! i) + +confTableFromList :: [(Text, a)] -> ConfTable a +confTableFromList l = unsafePerformIO do + d <- HT.fromList l + fd <- HT.unsafeFreeze d + pure $ ConfTable fd + +data Assoc = AssocL | AssocR | AssocNon + deriving (Eq, Show) + +data Prec = Prec + { binding :: Int, + assoc :: Assoc + } + deriving (Eq, Show) + +precLe :: Prec -> Prec -> Maybe Bool +precLe (Prec b a) (Prec b' a') + | b < b' = Just True + | b > b' = Just False + | otherwise = case (a, a') of + (AssocL, AssocL) -> Just False + (AssocR, AssocR) -> Just True + _ -> Nothing diff --git a/src/FNotation/Lexer.hs b/src/FNotation/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/FNotation/Lexer.hs @@ -0,0 +1,273 @@ +module FNotation.Lexer where + +import Data.Char (isDigit, isLetter, ord) +import Data.IORef +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Unsafe qualified as TU +import Data.Vector qualified as V +import Data.Vector.Mutable qualified as VM +import Diagnostician +import FNotation.Config +import FNotation.Names +import FNotation.Tokens +import Prettyprinter +import Prelude hiding (error, getChar, head, init, last, lex, lookup, span, tail) +import Prelude qualified as P + +-- Buffer +-------------------------------------------------------------------------------- + +data Buffer a = Buffer + { next :: IORef Int, + size :: Int, + values :: VM.IOVector a + } + +bufferWithCapacity :: Int -> IO (Buffer a) +bufferWithCapacity n = do + next <- newIORef 0 + values <- VM.unsafeNew n + pure $ Buffer next n values + +bufferUnsafeFreeze :: Buffer a -> IO (V.Vector a) +bufferUnsafeFreeze b = do + l <- readIORef b.next + V.take l <$> V.unsafeFreeze b.values + +push :: Buffer a -> a -> IO () +push b e = do + i <- readIORef b.next + if (i < b.size) + then do + VM.unsafeWrite b.values i e + writeIORef b.next (i + 1) + else P.error "cannot push because buffer is full" + +-- Lexer diagnostics +-------------------------------------------------------------------------------- + +data LexerCode + = UnexpectedCharacter + | UncontinuedQualifiedName + deriving (Eq, Ord) + +lexerCodeTable :: Map LexerCode CodeMeta +lexerCodeTable = + Map.fromList + [ (UnexpectedCharacter, CodeMeta 0 SError Nothing), + (UncontinuedQualifiedName, CodeMeta 1 SError Nothing) + ] + +-- Lex monad +-------------------------------------------------------------------------------- + +data LexState = LexState + { pos :: IORef Int, + prev :: IORef Int, + iter :: IORef TU.Iter, + out :: Buffer Token, + file :: File, + reporter :: ReporterFor LexerCode, + config :: ConfTable Kind + } + +-- Fundamental lexing actions +-------------------------------------------------------------------------------- + +span :: LexState -> IO Span +span st = Span <$> readIORef st.prev <*> readIORef st.pos + +emit :: LexState -> Kind -> TokenValue -> IO () +emit st k v = do + s <- span st + push st.out (Token k v s) + readIORef st.pos >>= writeIORef st.prev + +emit0 :: LexState -> Kind -> IO () +emit0 st k = emit st k VEmpty + +-- peek the character being currently scrutinized +peek :: LexState -> IO Char +peek st = do + TU.Iter c _ <- readIORef st.iter + pure c + +advance :: LexState -> IO () +advance st = do + let src = st.file.contents + TU.Iter _ j <- readIORef st.iter + i <- readIORef st.pos + let i' = i + j + writeIORef st.pos i' + if i' >= TU.lengthWord8 src + then writeIORef st.iter (TU.Iter '\0' 0) + else writeIORef st.iter (TU.iter src i') + +classify :: LexState -> Kind -> IO () +classify st k = advance st >> emit0 st k + +skip :: LexState -> IO () +skip st = do + advance st + readIORef st.pos >>= writeIORef st.prev + +advanceWhile :: LexState -> (Char -> Bool) -> IO () +advanceWhile st f = + peek st >>= \case + '\0' -> pure () + c -> + if f c + then advance st >> advanceWhile st f + else pure () + +slice :: LexState -> Span -> IO T.Text +slice st s = pure $ sliceWord8 s.start s.end st.file.contents + +isAlphaNum :: Char -> Bool +isAlphaNum c + | isLetter c = True + | isDigit c = True + | c == '_' || c == '-' = True + | otherwise = False + +-- TODO: more symbols, including unicode symbols? See issue #6 +isSymbol :: Char -> Bool +isSymbol = \case + '<' -> True + '>' -> True + '-' -> True + '+' -> True + '/' -> True + '*' -> True + '~' -> True + ':' -> True + '=' -> True + _ -> False + +report :: LexState -> LexerCode -> DDoc -> IO () +report st c m = do + s <- span st + let d = Diagnostic c m [Note (Just (SourceLoc (st.file) s)) Nothing] + reportTo st.reporter d + +unexpectedChar :: LexState -> Char -> IO () +unexpectedChar st c = do + advance st + report st UnexpectedCharacter $ "Unexpected character" <+> "'" <> pretty c <> "'" + +-- Lexemes +-------------------------------------------------------------------------------- + +sliceWhile :: LexState -> (Char -> Bool) -> IO Text +sliceWhile st f = do + s <- readIORef st.pos + advanceWhile st f + e <- readIORef st.pos + slice st (Span s e) + +classifyName :: LexState -> Name -> Kind +classifyName st x = case confTableLookup st.config x.last of + Just kind -> kind + Nothing -> + if isAlphaNumStart (T.head x.last) + then AIdent + else SIdent + +isAlphaNumStart :: Char -> Bool +isAlphaNumStart c + | isLetter c = True + | c == '_' = True + | otherwise = False + +nameSeg :: LexState -> IO Text +nameSeg st = + peek st >>= \case + c | isAlphaNumStart c -> sliceWhile st isAlphaNum + c | isSymbol c -> sliceWhile st isSymbol + _ -> P.error "nameSeg should only be called if current character is a letter" + +nameFromHeadTail :: Text -> [Text] -> Name +nameFromHeadTail head tail = + let go s [] = ([], s) + go s (t : ts) = let (ts', t') = go t ts in (s : ts', t') + (init, last) = go head tail + in Name init last + +-- | Lex a name +name :: LexState -> IO Name +name st = nameFromHeadTail <$> nameSeg st <*> tail + where + tail = + peek st >>= \case + '/' -> advance st >> (:) <$> nameSeg st <*> tail + _ -> pure [] + +ident :: LexState -> IO () +ident st = do + x <- name st + emit st (classifyName st x) (VName x) + +int :: LexState -> IO Int +int st = go 0 + where + go i = do + c <- peek st + if isDigit c + then advance st >> go (i * 10 + (ord c - ord '0')) + else pure i + +comment :: LexState -> IO () +comment st = do + advanceWhile st (/= '\n') + advance st + +string :: LexState -> IO () +string st = do + s <- readIORef st.pos + advance st + advanceWhile st (/= '\"') + advance st + e <- readIORef st.pos + x <- slice st (Span (s + 1) (e - 1)) + emit st String (VString x) + +-- Top-level lexing interface +-------------------------------------------------------------------------------- + +-- | Lex all the tokens +run :: LexState -> IO () +run st = + peek st >>= \case + '\t' -> skip st >> run st + ' ' -> skip st >> run st + '(' -> classify st LParen >> run st + ')' -> classify st RParen >> run st + '[' -> classify st LBrack >> run st + ']' -> classify st RBrack >> run st + '{' -> classify st LCurly >> run st + '}' -> classify st RCurly >> run st + ',' -> classify st Comma >> run st + ';' -> classify st Semicolon >> run st + '\n' -> classify st Nl >> run st + '#' -> comment st >> run st + '\"' -> string st >> run st + '.' -> advance st >> (name st >>= emit st Field . VName) >> run st + '\'' -> advance st >> (name st >>= emit st Tag . VName) >> run st + '\0' -> emit0 st Eof + c | isDigit c -> (int st >>= emit st Int . VInt) >> run st + c | isLetter c || c == '_' || isSymbol c -> ident st >> run st + c -> unexpectedChar st c >> run st + +-- | Run the lexer, return a vector of tokens ready for parsing. +lex :: ConfTable Kind -> ReporterFor LexerCode -> File -> IO (V.Vector Token) +lex config reporter file = do + pos <- newIORef 0 + prev <- newIORef 0 + iter <- newIORef $ TU.iter file.contents 0 + out <- bufferWithCapacity (TU.lengthWord8 file.contents) + let st = LexState pos prev iter out file reporter config + run st + bufferUnsafeFreeze st.out diff --git a/src/FNotation/Names.hs b/src/FNotation/Names.hs new file mode 100644 --- /dev/null +++ b/src/FNotation/Names.hs @@ -0,0 +1,29 @@ +module FNotation.Names where + +import Data.String (IsString, fromString) +import Data.Text (Text) +import Diagnostician +import Prettyprinter + +-- | A name of the form `a/b/c` +-- +-- The properties of a name (such as the precedence when used as an operator) are +-- determined by the *last* segment. Thus, `a/+` is an infix operator with the +-- same precedence as `+`. +-- +-- This also means, for instance, that if `theory` is a keyword, then `fresh/theory` +-- is also a keyword. +data Name = Name + { init :: [Text], + last :: Text + } + deriving (Eq, Ord) + +instance Show Name where + show x = mconcat ((<> "/") . show <$> x.init) <> show x.last + +instance DPretty Name where + dpretty x = mconcat ((<> "/") . pretty <$> x.init) <> pretty x.last + +instance IsString Name where + fromString s = Name [] (fromString s) diff --git a/src/FNotation/Parser.hs b/src/FNotation/Parser.hs new file mode 100644 --- /dev/null +++ b/src/FNotation/Parser.hs @@ -0,0 +1,322 @@ +module FNotation.Parser where + +import Data.IORef +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Vector qualified as V +import Diagnostician +import FNotation.Config +import FNotation.Names +import FNotation.Tokens qualified as T +import FNotation.Trees +import Prettyprinter +import Prelude hiding (lookup) + +-- Parser diagnostics +-------------------------------------------------------------------------------- + +data ParserCode + = UnexpectedToken + | DefaultedPrec + | IncompatiblePrecedences + deriving (Eq, Ord) + +parserCodeTable :: Map ParserCode CodeMeta +parserCodeTable = + Map.fromList + [ (UnexpectedToken, CodeMeta 0 SError Nothing), + (DefaultedPrec, CodeMeta 1 SWarning Nothing), + (IncompatiblePrecedences, CodeMeta 2 SError Nothing) + ] + +-- Parser monad +-------------------------------------------------------------------------------- + +data ParseState = ParseState + { pos :: IORef Int, + gas :: IORef Int, + skipNewlines :: IORef Bool, + tokens :: V.Vector T.Token, + file :: File, + reporter :: ReporterFor ParserCode, + config :: ConfTable Prec + } + +-- Parsing utilities +-------------------------------------------------------------------------------- + +report :: ParseState -> Span -> ParserCode -> DDoc -> IO () +report st s c m = do + let n = Note (Just (SourceLoc st.file s)) Nothing + let d = Diagnostic c m [n] + reportTo st.reporter d + +cur :: ParseState -> IO T.Kind +cur st = do + gas <- readIORef st.gas + if gas <= 0 + then do + pos <- readIORef st.pos + let token = V.unsafeIndex st.tokens pos + error $ "out of gas at token " ++ show (dpretty token) + else writeIORef st.gas (gas - 1) + pos <- readIORef st.pos + pure (V.unsafeIndex st.tokens pos).kind + +locally :: IORef a -> a -> IO b -> IO b +locally ref v action = do + old <- readIORef ref + writeIORef ref v + res <- action + writeIORef ref old + pure res + +ignoreNewlines :: ParseState -> IO a -> IO a +ignoreNewlines st = locally st.skipNewlines True + +withNewlines :: ParseState -> IO a -> IO a +withNewlines st = locally st.skipNewlines False + +curSpan :: ParseState -> IO Span +curSpan st = do + pos <- readIORef st.pos + pure (V.unsafeIndex st.tokens pos).span + +curValue :: ParseState -> IO T.TokenValue +curValue st = do + pos <- readIORef st.pos + pure (V.unsafeIndex st.tokens pos).value + +curName :: ParseState -> IO Name +curName st = + curValue st >>= \case + T.VName x -> pure x + _ -> error "expected token to be associated with a name" + +curInt :: ParseState -> IO Int +curInt st = + curValue st >>= \case + T.VInt x -> pure x + _ -> error "expected token to be associated with an int" + +curString :: ParseState -> IO Text +curString st = + curValue st >>= \case + T.VString x -> pure x + _ -> error "expected token to be associated with a string" + +at :: ParseState -> T.Kind -> IO Bool +at st k = (k ==) <$> cur st + +advance :: ParseState -> IO () +advance st = do + pos <- readIORef st.pos + let n = V.length st.tokens + if pos < n - 1 + then do + let next j + | j < n = case (V.unsafeIndex st.tokens j).kind of + T.Nl -> next (j + 1) + _ -> j + | otherwise = j + readIORef st.skipNewlines >>= \case + True -> writeIORef st.pos $ next (pos + 1) + False -> writeIORef st.pos $ pos + 1 + writeIORef st.gas 256 + else pure () + +eat :: ParseState -> T.Kind -> IO Bool +eat st k = + at st k >>= \case + True -> advance st >> pure True + False -> pure False + +reportUnexpected :: ParseState -> T.Kind -> T.Class -> IO () +reportUnexpected st k c = do + s <- curSpan st + report st s UnexpectedToken $ + "Unexpected token kind" <+> dpretty k <> ", expected" <+> dpretty c + +expect :: ParseState -> T.Kind -> IO () +expect st k = do + k' <- cur st + if k == k' + then advance st + else + reportUnexpected st k' (T.CSpecific k) >> pure () + +openingPos :: ParseState -> IO Pos +openingPos st = (.start) <$> curSpan st + +close :: ParseState -> Pos -> (Span -> Ntn) -> IO Ntn +close st s f = do + (Span _ e) <- curSpan st + pure $ f (Span s e) + +advanceClose :: ParseState -> Pos -> (Span -> Ntn) -> IO Ntn +advanceClose st s f = do + n <- close st s f + advance st + pure n + +-- The fnotation grammar +-------------------------------------------------------------------------------- + +argStarts :: V.Vector T.Kind +argStarts = + V.fromList + [ T.LParen, + T.LBrack, + T.AIdent, + T.AKeyword, + T.Field, + T.Tag, + T.Int, + T.Block + ] + +argStart :: T.Kind -> Bool +argStart k = V.elem k argStarts + +tupleElems :: ParseState -> IO [Ntn] +tupleElems st = + cur st >>= \case + T.RBrack -> pure [] + k | argStart k -> do + n <- expr st + cur st >>= \case + T.RBrack -> pure [n] + T.Comma -> do + advance st + ns <- tupleElems st + pure $ n : ns + k' -> do + reportUnexpected st k' T.CTupleMark + pure [n] + k -> do + reportUnexpected st k T.CExprStart + pure [] + +arg :: ParseState -> IO Ntn +arg st = do + m <- openingPos st + cur st >>= \case + T.LParen -> do + e <- ignoreNewlines st $ do + advance st + expr st + expect st T.RParen + pure e + T.LBrack -> do + ns <- ignoreNewlines st $ do + advance st + tupleElems st + expect st T.RBrack + close st m $ Tuple ns + T.AIdent -> do + x <- curName st + advanceClose st m $ Ident x + T.AKeyword -> do + x <- curName st + advanceClose st m $ Keyword x + T.Field -> do + x <- curName st + advanceClose st m $ Field x + T.Int -> do + i <- curInt st + advanceClose st m $ Int i + T.String -> do + x <- curString st + advanceClose st m $ String x + T.Block -> block st + k -> error $ "should only call arg when the starting token is in argStarts, got: " ++ show k + +args :: ParseState -> IO [Ntn] +args st = do + k <- cur st + if argStart k + then (:) <$> arg st <*> args st + else pure [] + +expr :: ParseState -> IO Ntn +expr st = arg st >>= go (Prec 0 AssocNon) + where + go p lhs = do + cur st >>= \case + k@(T.SIdent; T.SKeyword) -> do + s <- curSpan st + x <- curName st + let n = case k of + T.SIdent -> Ident x s + T.SKeyword -> Keyword x s + p' <- case confTableLookup st.config x.last of + Just p' -> pure p' + Nothing -> do + report st s DefaultedPrec $ + "Defaulted precedence of" <+> dpretty x <+> "to the same as +" + pure $ Prec 50 AssocL + case precLe p p' of + Nothing -> do + report st s IncompatiblePrecedences "Incompatible precedences" + pure lhs + Just False -> pure lhs + Just True -> do + advance st + rhs <- arg st >>= go p' + go p (Infix lhs n rhs) + k | argStart k -> do + spine <- args st + go p (App lhs spine) + _ -> pure lhs + +stmt :: ParseState -> IO Ntn +stmt st = do + cur st >>= \case + T.Decl -> do + m <- openingPos st + x <- curName st + advance st + n <- expr st + expect st T.Nl + pure $ Decl x n (Span m (endPos n)) + _ -> expr st + +stmts :: ParseState -> IO [Ntn] +stmts st = go [] + where + go ns = + cur st >>= \case + T.Nl -> do + advance st + go ns + k | k == T.End || k == T.Eof -> pure $ reverse ns + _ -> do + n <- stmt st + go $ n : ns + +block :: ParseState -> IO Ntn +block st = + cur st >>= \case + T.Block -> do + m <- openingPos st + x <- curName st + advance st + h <- + cur st >>= \case + k | argStart k -> Just <$> arg st + _ -> pure Nothing + ns <- stmts st + advanceClose st m $ Block x h ns + _ -> error "expected a block" + +-- Toplevel parsing interface +-------------------------------------------------------------------------------- + +parse :: ConfTable Prec -> ReporterFor ParserCode -> File -> V.Vector T.Token -> IO [Ntn] +parse config reporter file tokens = do + pos <- newIORef 0 + gas <- newIORef 256 + skipNewlines <- newIORef False + let st = ParseState pos gas skipNewlines tokens file reporter config + stmts st diff --git a/src/FNotation/Pretty.hs b/src/FNotation/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/FNotation/Pretty.hs @@ -0,0 +1,72 @@ +module FNotation.Pretty where + +import Diagnostician +import FNotation.Config +import FNotation.Names +import FNotation.Trees +import Prettyprinter + +data PrevPrec + = LeftOf Prec + | RightOf Prec + | Top + | Bot + +tighter :: Prec -> PrevPrec -> Bool +tighter _ Top = True +tighter _ Bot = False +tighter (Prec b a) (LeftOf (Prec b' a')) + | b > b' = True + | b < b' = False + | a == AssocL && a' == AssocL = True + | otherwise = False +tighter (Prec b a) (RightOf (Prec b' a')) + | b > b' = True + | b < b' = False + | a == AssocR && a' == AssocR = True + | otherwise = False + +looser :: Prec -> PrevPrec -> Bool +looser p p' = not $ tighter p p' + +type ConfigArg = (?config :: ConfTable Prec) + +prtTop :: (ConfigArg) => NtnGeneric a -> DDoc +prtTop = prt Top + +precApp :: Prec +precApp = Prec 100 AssocL + +par :: Bool -> DDoc -> DDoc +par True d = enclose "(" ")" d +par False d = d + +prt :: (ConfigArg) => PrevPrec -> NtnGeneric a -> DDoc +prt p = \case + App n ns -> + par (looser precApp p) $ + prt (LeftOf precApp) n <+> hsep (prt (RightOf precApp) <$> ns) + Infix l n r -> + let mp' = case n of + Ident x _ -> confTableLookup ?config x.last + Keyword x _ -> confTableLookup ?config x.last + _ -> Nothing + p' = maybe (Prec 50 AssocL) id mp' + in par (looser p' p) (prt (LeftOf p') l <+> prt Bot n <+> prt (RightOf p') r) + Block x hd stmts _ -> + vsep $ + [dpretty x <> maybe mempty prtTop hd] + ++ [indent 2 $ prtTop stmt | stmt <- stmts] + ++ ["end"] + Decl x n _ -> dpretty x <+> prtTop n + Ident x _ -> dpretty x + Keyword x _ -> dpretty x + Field x _ -> "." <> dpretty x + Tag x _ -> "'" <> dpretty x + Int i _ -> pretty i + String x _ -> "\"" <> pretty x <> "\"" + Tuple ns _ -> list $ prtTop <$> ns + Error _ -> "" + +dprettyWithPrecs :: ConfTable Prec -> NtnGeneric a -> DDoc +dprettyWithPrecs config n = let ?config = config in prtTop n diff --git a/src/FNotation/Tokens.hs b/src/FNotation/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/FNotation/Tokens.hs @@ -0,0 +1,84 @@ +module FNotation.Tokens where + +import Data.Text (Text) +import Diagnostician +import FNotation.Names +import Prettyprinter + +-- Token kinds +-------------------------------------------------------------------------------- + +data Kind + = -- | alphanumerical identifier + AIdent + | -- | alphanumerical keyword + AKeyword + | -- | symbolic identifier + SIdent + | -- | symbolic keyword + SKeyword + | Decl + | Block + | End + | Tag + | Field + | Int + | String + | LParen + | RParen + | LBrack + | RBrack + | LCurly + | RCurly + | Comma + | Semicolon + | Nl + | Eof + | Error + deriving (Eq, Show) + +instance DPretty Kind where + dpretty k = pretty (show k) + +-- Tokens +-------------------------------------------------------------------------------- + +data TokenValue = VEmpty | VName Name | VInt Int | VString Text + deriving (Eq, Show) + +-- | A @Token@ consists of a kind along with an attached value and a source code +-- location. +-- +-- We split the kind and the attached value so that we can store a set of token +-- kinds as a data structure; otherwise the only way to classify tokens would be +-- functions. +data Token = Token + { kind :: Kind, + value :: TokenValue, + span :: Span + } + deriving (Eq) + +instance DPretty Token where + dpretty (Token k v s) = dpretty k <> pv <+> "(" <> dpretty s <> ")" + where + pv = case v of + VEmpty -> mempty + VName x -> " " <> dpretty x + VInt i -> " " <> pretty i + VString i -> " " <> pretty i + +-- Token classes (used for error messages) +-------------------------------------------------------------------------------- + +data Class + = CSpecific Kind + | CExprStart + | CTupleMark + +instance DPretty Class where + dpretty = \case + CSpecific k -> dpretty k + CExprStart -> "a token that can start an expression" + CTupleMark -> + "a token that can follow an element of a tuple, e.g. ',' or ']'" diff --git a/src/FNotation/Trees.hs b/src/FNotation/Trees.hs new file mode 100644 --- /dev/null +++ b/src/FNotation/Trees.hs @@ -0,0 +1,106 @@ +module FNotation.Trees where + +import Data.Maybe (maybeToList) +import Data.Text (Text) +import Diagnostician +import FNotation.Names +import Prettyprinter +import Prelude hiding (head, span) + +-- Notation data structure +-------------------------------------------------------------------------------- + +-- | Notation is the output of parsing. +-- +-- Each notation is associated with a span. Most variants store that span; `App` +-- and `Infix` don't because the span can be inferred by looking at the left and +-- right children. +-- +-- In the variants which take a span, we put the span last because in the parser +-- we have utility methods which take `Span -> Ntn`, and if the span is last, we +-- can use currying to our advantage here. +data NtnGeneric a + = App (NtnGeneric a) [NtnGeneric a] + | Infix (NtnGeneric a) (NtnGeneric a) (NtnGeneric a) + | Block Name (Maybe (NtnGeneric a)) [NtnGeneric a] a + | Decl Name (NtnGeneric a) a + | Tuple [NtnGeneric a] a + | Ident Name a + | Keyword Name a + | Field Name a + | Tag Name a + | Int Int a + | String Text a + | Error a + +type Ntn = NtnGeneric Span + +type Ntn0 = NtnGeneric () + +startPos :: Ntn -> Pos +startPos (App f _) = startPos f +startPos (Infix x _ _) = startPos x +startPos (Block _ _ _ s) = s.start +startPos (Decl _ _ s) = s.start +startPos (Ident _ s) = s.start +startPos (Keyword _ s) = s.start +startPos (Field _ s) = s.start +startPos (Tag _ s) = s.start +startPos (Int _ s) = s.start +startPos (String _ s) = s.start +startPos (Tuple _ s) = s.start +startPos (Error s) = s.start + +endPos :: Ntn -> Pos +endPos (App _ xs) = endPos (last xs) +endPos (Infix _ _ y) = endPos y +endPos (Block _ _ _ s) = s.end +endPos (Decl _ _ s) = s.end +endPos (Ident _ s) = s.end +endPos (Keyword _ s) = s.end +endPos (Field _ s) = s.end +endPos (Tag _ s) = s.end +endPos (Int _ s) = s.end +endPos (String _ s) = s.end +endPos (Tuple _ s) = s.end +endPos (Error s) = s.end + +span :: Ntn -> Span +span n = Span (startPos n) (endPos n) + +-- Debug printing for notation +-------------------------------------------------------------------------------- + +head :: Ntn -> DDoc +head (App _ _) = "App" +head (Infix _ _ _) = "Infix" +head (Block x _ _ _) = "Block" <+> dpretty x +head (Decl x _ _) = "Decl" <+> dpretty x +head (Ident x _) = "Ident" <+> dpretty x +head (Keyword x _) = "Keyword" <+> dpretty x +head (Field x _) = "Field" <+> dpretty x +head (Tag x _) = "Tag" <+> dpretty x +head (Int i _) = "Int" <+> pretty i +head (String i _) = "Int" <+> pretty i +head (Tuple _ _) = "Tuple" +head (Error _) = "Error" + +children :: Ntn -> [Ntn] +children (App f xs) = f : xs +children (Infix x op y) = [x, op, y] +children (Block _ mh xs _) = maybeToList mh ++ xs +children (Decl _ x _) = [x] +children (Ident _ _) = [] +children (Keyword _ _) = [] +children (Field _ _) = [] +children (Tag _ _) = [] +children (Int _ _) = [] +children (String _ _) = [] +children (Tuple ns _) = ns +children (Error _) = [] + +instance DPretty Ntn where + dpretty n = if null cs then h else vsep [h, indent 2 $ vsep cs] + where + h = head n <+> "(" <> dpretty (span n) <> ")" + cs = map dpretty (children n) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,108 @@ +module Main (main) where + +import Prelude hiding (lex) +import Data.ByteString.Lazy qualified as LBS +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Vector qualified as V +import Data.Text.IO.Utf8 qualified as T +import Data.Text.Lazy.Encoding qualified as TLE +import Diagnostician +import FNotation +import FNotation.Tokens qualified as K +import Prettyprinter +import Prettyprinter.Render.Text +import Test.Tasty (defaultMain, TestTree, testGroup) +import Test.Tasty.Golden (goldenVsString, findByExtension) +import System.FilePath (takeBaseName, replaceExtension) +import System.IO +import System.IO.Temp (withSystemTempFile) + +main :: IO () +main = defaultMain =<< goldenTests + +render :: DDoc -> LBS.ByteString +render = TLE.encodeUtf8 . renderLazy . layoutPretty defaultLayoutOptions + +lexConfig :: ConfTable Kind +lexConfig = confTableFromList + [ ("sig", K.Block), + ("struct", K.Block), + ("sum", K.Block), + ("match", K.Block), + ("theory", K.Decl), + ("def", K.Decl), + ("type", K.Decl), + ("let", K.Decl), + ("open", K.Decl), + ("import", K.Decl), + ("end", K.End), + ("Type", K.AKeyword), + ("Int", K.AKeyword), + ("String", K.AKeyword), + (":=", K.SKeyword), + ("=", K.SKeyword), + (":", K.SKeyword), + ("->", K.SKeyword), + ("=>", K.SKeyword) + ] + +parseConfig :: ConfTable Prec +parseConfig = confTableFromList + [ (":=", Prec 10 AssocNon), + (":", Prec 20 AssocNon), + ("->", Prec 30 AssocR), + ("=>", Prec 30 AssocR), + ("=", Prec 40 AssocNon), + ("+", Prec 50 AssocL), + ("-", Prec 50 AssocL), + ("*", Prec 60 AssocL), + ("/", Prec 60 AssocL) + ] + +data TestCode = LexerCode LexerCode | ParserCode ParserCode + deriving (Eq, Ord) + +codeTable :: Map TestCode CodeMeta +codeTable = mconcat + [ promoteCodeTable lexerCodeTable LexerCode 0, + promoteCodeTable parserCodeTable ParserCode 100 + ] + +instance Code TestCode where + codeMeta c = case Map.lookup c codeTable of + Just m -> m + Nothing -> error "unregistered code" + +parseToPretty :: FilePath -> IO LBS.ByteString +parseToPretty fp = do + src <- T.readFile fp + let f = newFile fp src + withSystemTempFile "reporter-output" $ \path h -> do + let r = Reporter h False + tokens <- lex lexConfig (ReporterFor LexerCode r) f + ns <- parse parseConfig (ReporterFor ParserCode r) f tokens + hFlush h + hClose h + msgs <- T.readFile path + pure $ render $ vsep [ + "-- tokens", + vsep $ dpretty <$> V.toList tokens, + "", + "-- notation", + vsep $ dpretty <$> ns, + "", + "-- pretty", + vsep $ dprettyWithPrecs parseConfig <$> ns, + "", + "-- messages", + pretty $ msgs] + +goldenTests :: IO TestTree +goldenTests = do + ntnFiles <- findByExtension [".ntn"] "." + return $ testGroup "FNotation golden tests" + [ goldenVsString (takeBaseName ntnFile) outputFile (parseToPretty ntnFile) + | ntnFile <- ntnFiles + , let outputFile = replaceExtension ntnFile ".output" + ]