diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for language-Modula2 +## 0.1.2 -- 2022-10-09 + +* Compiling with GHC 9 +* Incremented dependency bounds and adjusted code +* Shortened the Atts type instances +* Removed the Auto instances of At and Full.Functor, now universal +* Reusing the Language.Oberon.ConstantFolder attribute rules +* Relaxed the ConstantFolder constraints + ## 0.1 -- 2020-11-01 * First version. Released on an unsuspecting world. diff --git a/language-Modula2.cabal b/language-Modula2.cabal --- a/language-Modula2.cabal +++ b/language-Modula2.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: language-Modula2 -version: 0.1 +version: 0.1.2 synopsis: Parser, pretty-printer, and more for the Modula-2 programming language description: The library and the executable supports two versions of the Modula-2 programming language: as described by the @@ -24,10 +24,10 @@ Language.Modula2.ISO.Abstract, Language.Modula2.ISO.AST, Language.Modula2.ISO.Grammar, Language.Modula2.ISO.Pretty, Language.Modula2.ISO.ConstantFolder -- other-modules: - build-depends: base >= 4.7 && < 5, text < 1.3, containers >= 0.5 && < 1.0, filepath < 1.5, directory < 1.4, - parsers >= 0.12.7 && < 0.13, input-parsers < 0.2, prettyprinter >= 1.2.1 && < 1.7, - rank2classes >= 1.3 && < 1.5, grammatical-parsers >= 0.5 && < 0.6, deep-transformations < 0.2, - template-haskell >= 2.11 && < 2.17, + build-depends: base >= 4.7 && < 5, text < 3, containers >= 0.5 && < 1.0, filepath < 1.5, directory < 1.4, + parsers >= 0.12.7 && < 0.13, input-parsers >= 0.2.2 && < 0.4, prettyprinter >= 1.2.1 && < 1.7, + rank2classes >= 1.3 && < 1.5, grammatical-parsers >= 0.5 && < 0.8, deep-transformations == 0.2.*, + template-haskell >= 2.11 && < 2.20, language-oberon >= 0.3 && < 0.4 hs-source-dirs: src default-language: Haskell2010 @@ -36,9 +36,9 @@ main-is: app/Parse.hs -- other-modules: other-extensions: RankNTypes, RecordWildCards, ScopedTypeVariables, FlexibleInstances, DeriveDataTypeable - build-depends: base >= 4.7 && < 5, text < 1.3, either == 5.*, containers >= 0.5 && < 1.0, + build-depends: base >= 4.7 && < 5, text, either == 5.*, containers >= 0.5 && < 1.0, repr-tree-syb < 0.2, filepath < 1.5, prettyprinter, - rank2classes, grammatical-parsers, deep-transformations < 0.2, + rank2classes, grammatical-parsers, deep-transformations, optparse-applicative, language-oberon >= 0.3 && < 0.4, language-Modula2 @@ -46,9 +46,9 @@ test-suite examples type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5, text < 1.3, grammatical-parsers, + build-depends: base >= 4.7 && < 5, text, grammatical-parsers, either == 5.*, directory < 2, filepath < 1.5, prettyprinter, - deep-transformations < 0.2, + deep-transformations, tasty >= 0.7, tasty-hunit, language-oberon >= 0.3 && < 0.4, language-Modula2 diff --git a/src/Language/Modula2.hs b/src/Language/Modula2.hs --- a/src/Language/Modula2.hs +++ b/src/Language/Modula2.hs @@ -12,7 +12,7 @@ import qualified Language.Modula2.ISO.Grammar as ISO.Grammar import qualified Language.Modula2.ConstantFolder as ConstantFolder import qualified Language.Modula2.ISO.ConstantFolder as ISO.ConstantFolder -import Language.Modula2.ConstantFolder (Sem, ConstantFold, InhCF, SynCFExp, SynCFMod') +import Language.Modula2.ConstantFolder (ConstantFold) import Language.Modula2.Pretty () import Language.Modula2.ISO.Pretty () diff --git a/src/Language/Modula2/AST.hs b/src/Language/Modula2/AST.hs --- a/src/Language/Modula2/AST.hs +++ b/src/Language/Modula2/AST.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GADTs, DataKinds, InstanceSigs, KindSignatures, +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GADTs, DataKinds, InstanceSigs, KindSignatures, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} diff --git a/src/Language/Modula2/ConstantFolder.hs b/src/Language/Modula2/ConstantFolder.hs --- a/src/Language/Modula2/ConstantFolder.hs +++ b/src/Language/Modula2/ConstantFolder.hs @@ -1,25 +1,22 @@ {-# LANGUAGE DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleContexts, FlexibleInstances, + InstanceSigs, MultiParamTypeClasses, OverloadedStrings, RankNTypes, - ScopedTypeVariables, TemplateHaskell, TypeFamilies, UndecidableInstances #-} + ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} -- | The main export of this module is the function 'foldConstants' that folds the constants in a Modula-2 AST using -- an attribute grammar. Other exports are helper functions and attribute types that can be reused for other languages -- or attribute grammars. module Language.Modula2.ConstantFolder (foldConstants, - ConstantFold, Sem, Environment, - InhCF, SynCF(..), SynCFDesignator(..), SynCFExp(..), SynCFMod(..), SynCFMod', - foldBinaryArithmetic, foldBinaryBoolean, - foldBinaryFractional, foldBinaryInteger, - maxCardinal, maxInteger, minInteger, maxInt32, minInt32, maxSet, minSet, - doubleSize, floatSize, intSize, int32Size, - maxReal, minReal) where + ConstantFold, Sem, Environment, InhCF, + SynCF(..), SynCFDesignator(..), SynCFExp(..), SynCFMod(..), SynCFMod') where import Control.Applicative (liftA2, ZipList(ZipList, getZipList)) import Control.Arrow (first) import Control.Monad (join) import Data.Bits (shift) import Data.Char (chr, ord, toUpper) +import Data.Coerce (Coercible, coerce) import Data.Functor.Identity (Identity(..)) import Data.Int (Int32) import Data.Foldable (fold) @@ -30,7 +27,6 @@ import qualified Data.Text as Text import Foreign.Storable (sizeOf) import GHC.Generics (Generic) -import Language.Haskell.TH (appT, conT, varT, varE, newName) import Data.Text.Prettyprint.Doc (Pretty) import qualified Rank2 @@ -101,33 +97,30 @@ ~(Modules fs) <*> ~(Modules ms) = Modules (Map.intersectionWith Rank2.apply fs ms) -- * Boring attribute types -type instance Atts (Synthesized (Auto ConstantFold)) (Modules l _ _) = SynCFRoot (Modules l Placed Identity) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Module λ l _ _) = SynCFMod' l (AST.Module λ l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Declaration full λ l _ _) = SynCFMod' l (AST.Declaration full λ l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.ProcedureHeading λ l _ _) = SynCF' (AST.ProcedureHeading λ l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Type λ l _ _) = SynCF' (AST.Type λ l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.FieldList λ l _ _) = SynCF' (AST.FieldList λ l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Expression λ l _ _) = SynCFExp λ l -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Designator λ l _ _) = SynCFDesignator l -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Statement λ l _ _) = SynCF' (AST.Statement λ l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Variant λ l _ _) = SynCF' (AST.Variant λ l) +type instance Atts (Synthesized ConstantFold) (Modules l _ _) = SynCFRoot (Modules l Placed Identity) +type instance Atts (Synthesized ConstantFold) (AST.Module λ l _ _) = SynCFMod' l (AST.Module λ l) +type instance Atts (Synthesized ConstantFold) (AST.Declaration full λ l _ _) = SynCFMod' l (AST.Declaration full λ l) +type instance Atts (Synthesized ConstantFold) (AST.ProcedureHeading λ l _ _) = SynCF' (AST.ProcedureHeading λ l) +type instance Atts (Synthesized ConstantFold) (AST.Type λ l _ _) = SynCF' (AST.Type λ l) +type instance Atts (Synthesized ConstantFold) (AST.FieldList λ l _ _) = SynCF' (AST.FieldList λ l) +type instance Atts (Synthesized ConstantFold) (AST.Expression λ l _ _) = SynCFExp λ l +type instance Atts (Synthesized ConstantFold) (AST.Designator λ l _ _) = SynCFDesignator l +type instance Atts (Synthesized ConstantFold) (AST.Statement λ l _ _) = SynCF' (AST.Statement λ l) +type instance Atts (Synthesized ConstantFold) (AST.Variant λ l _ _) = SynCF' (AST.Variant λ l) -type instance Atts (Inherited (Auto ConstantFold)) (Modules l _ _) = InhCFRoot l -type instance Atts (Inherited (Auto ConstantFold)) (AST.Module λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Declaration full λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.ProcedureHeading λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Type λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.FieldList λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Expression λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Designator λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Statement λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Variant λ l _ _) = InhCF λ +type instance Atts (Inherited ConstantFold) (Modules l _ _) = InhCFRoot l +type instance Atts (Inherited ConstantFold) (AST.Module λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Declaration full λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.ProcedureHeading λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Type λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.FieldList λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Expression λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Designator λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Statement λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Variant λ l _ _) = InhCF l type Placed = (,) (Int, ParsedLexemes, Int) -wrap :: a -> Mapped Placed a -wrap = Mapped . (,) (0, Trailing [], 0) - -- * Rules instance Ord (Abstract.QualIdent l) => Attribution (Auto ConstantFold) (Modules l) Sem Placed where @@ -180,82 +173,17 @@ | otherwise = qname synthesizedField _ _ _ _ _ = mempty -instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), Abstract.Modula2 λ, - Abstract.Value l ~ AST.Value l, Abstract.QualIdent l ~ AST.QualIdent l, +instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), + Abstract.Expression λ ~ AST.Expression AST.Language, Abstract.QualIdent λ ~ AST.QualIdent AST.Language, + Abstract.QualIdent l ~ AST.QualIdent l, + Abstract.Element l l ~ AST.Element l l, + Abstract.Value l l ~ AST.Value l l, + λ ~ AST.Language, Pretty (AST.Value l l Identity Identity), Atts (Synthesized (Auto ConstantFold)) (Abstract.Expression l l Sem Sem) ~ SynCFExp l l, - Atts (Synthesized (Auto ConstantFold)) (Abstract.Element l l Sem Sem) ~ SynCF' (Abstract.Element l l), + Atts (Synthesized (Auto ConstantFold)) (Abstract.Element l l Sem Sem) ~ SynCF' (AST.Element l l), Atts (Synthesized (Auto ConstantFold)) (Abstract.Designator l l Sem Sem) ~ SynCFDesignator l) => Synthesizer (Auto ConstantFold) (AST.Expression λ l) Sem Placed where - synthesis _ (pos@(start, ls, end), AST.Relation op _ _) _ (AST.Relation _op left right) = - case join (compareValues <$> foldedValue (syn left) <*> foldedValue (syn right)) - of Just value -> Oberon.literalSynthesis value - Nothing -> SynCFExp{folded= Mapped (pos, - Abstract.relation op (foldedExp' $ syn left) (foldedExp' $ syn right)), - foldedValue= Nothing} - where compareValues (_, AST.Boolean l) (ls, AST.Boolean r) = repos ls <$> relate op (compare l r) - compareValues (_, AST.Integer l) (ls, AST.Integer r) = repos ls <$> relate op (compare l r) - compareValues (_, AST.Real l) (ls, AST.Real r) = repos ls <$> relate op (compare l r) - compareValues (_, AST.Integer l) (ls, AST.Real r) = repos ls <$> relate op (compare (fromIntegral l) r) - compareValues (_, AST.Real l) (ls, AST.Integer r) = repos ls <$> relate op (compare l (fromIntegral r)) - compareValues (_, AST.CharCode l) (ls, AST.CharCode r) = repos ls <$> relate op (compare l r) - compareValues (_, AST.String l) (ls, AST.String r) = repos ls <$> relate op (compare l r) - compareValues (_, AST.CharCode l) (ls, AST.String r) = repos ls - <$> relate op (compare (Text.singleton $ chr l) r) - compareValues (_, AST.String l) (ls, AST.CharCode r) = repos ls - <$> relate op (compare l (Text.singleton $ chr r)) - compareValues _ _ = Nothing - repos (_, ls', _) v = ((start, anyWhitespace ls ls', end), v) - relate Abstract.Equal EQ = Just Abstract.true - relate Abstract.Equal _ = Just Abstract.false - relate Abstract.Unequal EQ = Just Abstract.false - relate Abstract.Unequal _ = Just Abstract.true - relate Abstract.Less LT = Just Abstract.true - relate Abstract.Less _ = Just Abstract.false - relate Abstract.LessOrEqual GT = Just Abstract.false - relate Abstract.LessOrEqual _ = Just Abstract.true - relate Abstract.Greater GT = Just Abstract.true - relate Abstract.Greater _ = Just Abstract.false - relate Abstract.GreaterOrEqual LT = Just Abstract.false - relate Abstract.GreaterOrEqual _ = Just Abstract.true - relate Abstract.In _ = Nothing - synthesis _ (pos@(start, ls, end), _) _ (AST.Positive expr) = - case foldedValue (syn expr) - of Just ((_, ls', _), AST.Integer n) -> Oberon.literalSynthesis ((start, anyWhitespace ls ls', end), - AST.Integer n) - Just ((_, ls', _), AST.Real n) -> Oberon.literalSynthesis ((start, anyWhitespace ls ls', end), AST.Real n) - _ -> SynCFExp{folded= Mapped (pos, Abstract.positive $ foldedExp' $ syn expr), - foldedValue= Nothing} - synthesis _ (pos@(start, ls, end), _) _ (AST.Negative expr) = - case foldedValue (syn expr) - of Just ((_, ls', _), AST.Integer n) -> Oberon.literalSynthesis ((start, anyWhitespace ls ls', end), - AST.Integer $ negate n) - Just ((_, ls', _), AST.Real n) -> Oberon.literalSynthesis ((start, anyWhitespace ls ls', end), - AST.Real $ negate n) - _ -> SynCFExp{folded= Mapped (pos, Abstract.negative $ foldedExp' $ syn expr), - foldedValue= Nothing} - synthesis _ (pos, _) _ (AST.Add left right) = - foldBinaryArithmetic pos Abstract.add (+) (syn left) (syn right) - synthesis _ (pos, _) _ (AST.Subtract left right) = - foldBinaryArithmetic pos Abstract.subtract (-) (syn left) (syn right) - synthesis _ (pos, _) _ (AST.Or left right) = - foldBinaryBoolean pos Abstract.or (||) (syn left) (syn right) - synthesis _ (pos, _) _ (AST.Multiply left right) = - foldBinaryArithmetic pos Abstract.multiply (*) (syn left) (syn right) - synthesis _ (pos, _) _ (AST.Divide left right) = - foldBinaryFractional pos Abstract.divide (/) (syn left) (syn right) - synthesis _ (pos, _) _ (AST.IntegerDivide left right) = - foldBinaryInteger pos Abstract.integerDivide div (syn left) (syn right) - synthesis _ (pos, _) _ (AST.Modulo left right) = - foldBinaryInteger pos Abstract.modulo mod (syn left) (syn right) - synthesis _ (pos, _) _ (AST.And left right) = - foldBinaryBoolean pos Abstract.and (&&) (syn left) (syn right) - synthesis _ (pos@(start, ls, end), _) _ (AST.Not expr) = - case foldedValue (syn expr) - of Just ((_, ls', _), AST.Boolean b) -> Oberon.literalSynthesis ((start, anyWhitespace ls ls', end), - if b then Abstract.false else Abstract.true) - _ -> SynCFExp{folded= Mapped (pos, Abstract.not $ foldedExp' $ syn expr), - foldedValue= Nothing} synthesis _ (pos, AST.Set t _elements) _ (AST.Set _t elements) = SynCFExp{folded= Mapped (pos, Abstract.set t (getMapped . folded' . syn <$> getZipList elements)), foldedValue= Nothing} @@ -264,146 +192,46 @@ of (Just val, _) -> Oberon.literalSynthesis val (Nothing, (pos', des')) -> SynCFExp{folded= Mapped (pos, Abstract.read (pos', des')), foldedValue= Nothing} - synthesis _ (pos, AST.FunctionCall fn1 args1) inheritance (AST.FunctionCall fn args) = - case (snd <$> designatorValue (syn fn :: SynCFDesignator l), (snd <$>) . foldedValue . syn <$> getZipList args) - of (Just (AST.Builtin "CAP"), [Just (AST.String s)]) - | Text.length s == 1, capital <- Text.toUpper s -> fromValue (Abstract.string capital) - (Just (AST.Builtin "CAP"), [Just (AST.CharCode c)]) - | capital <- ord (toUpper $ chr c) -> fromValue (Abstract.charCode capital) - (Just (AST.Builtin "CHR"), [Just (AST.Integer code)]) -> fromValue (Abstract.charCode $ fromIntegral code) - (Just (AST.Builtin "ORD"), [Just (AST.String s)]) - | Text.length s == 1, code <- ord (Text.head s) -> fromValue (Abstract.integer $ toInteger code) - (Just (AST.Builtin "ORD"), [Just (AST.CharCode code)]) -> fromValue (Abstract.integer $ toInteger code) - (Just (AST.Builtin "ABS"), [Just (AST.Integer i)]) -> fromValue (Abstract.integer $ abs i) - (Just (AST.Builtin "ABS"), [Just (AST.Real r)]) -> fromValue (Abstract.real $ abs r) - (Just (AST.Builtin "ASH"), [Just (AST.Integer i), Just (AST.Integer j)]) - | shifted <- shift i (fromIntegral j) -> fromValue (Abstract.integer shifted) - (Just (AST.Builtin "TRUNC"), [Just (AST.Real x)]) -> fromValue (Abstract.integer $ floor x) - (Just (AST.Builtin "FLOAT"), [Just (AST.Integer x)]) -> fromValue (Abstract.real $ fromIntegral x) - (Just (AST.Builtin "FLOAT"), [Just (AST.Real x)]) -> fromValue (Abstract.real x) - (Just (AST.Builtin "LEN"), [Just (AST.String s)]) -> fromValue (Abstract.integer $ toInteger $ Text.length s) - (Just (AST.Builtin "LONG"), [Just (AST.Integer x)]) -> fromValue (Abstract.integer x) - (Just (AST.Builtin "LONG"), [Just (AST.Real x)]) -> fromValue (Abstract.real x) - (Just (AST.Builtin "SHORT"), [Just (AST.Integer x)]) -> fromValue (Abstract.integer x) - (Just (AST.Builtin "SHORT"), [Just (AST.Real x)]) -> fromValue (Abstract.real x) - (Just (AST.Builtin "ODD"), [Just (AST.Integer x)]) -> - fromValue (if x `mod` 2 == 1 then Abstract.true else Abstract.false) - (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "INTEGER")]) -> fromValue (Abstract.integer intSize) - (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "LONGINT")]) -> fromValue (Abstract.integer intSize) - (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "CARDINAL")]) -> fromValue (Abstract.integer intSize) - (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "REAL")]) -> fromValue (Abstract.integer doubleSize) - (Just (AST.Builtin "SIZE"), [Just (AST.Builtin "LONGREAL")]) -> fromValue (Abstract.integer doubleSize) - (Just (AST.Builtin "MAX"), [Just (AST.Builtin "CHAR")]) -> fromValue (Abstract.charCode 0xff) - (Just (AST.Builtin "MAX"), [Just (AST.Builtin "INTEGER")]) -> fromValue (Abstract.integer maxInteger) - (Just (AST.Builtin "MAX"), [Just (AST.Builtin "LONGINT")]) -> fromValue (Abstract.integer maxInteger) - (Just (AST.Builtin "MAX"), [Just (AST.Builtin "CARDINAL")]) -> fromValue (Abstract.integer maxCardinal) - (Just (AST.Builtin "MAX"), [Just (AST.Builtin "BITSET")]) -> fromValue (Abstract.integer maxSet) - (Just (AST.Builtin "MAX"), [Just (AST.Builtin "REAL")]) -> fromValue (Abstract.real maxReal) - (Just (AST.Builtin "MAX"), [Just (AST.Builtin "LONGREAL")]) -> fromValue (Abstract.real maxReal) - (Just (AST.Builtin "MIN"), [Just (AST.Builtin "CHAR")]) -> fromValue (Abstract.charCode 0) - (Just (AST.Builtin "MIN"), [Just (AST.Builtin "INTEGER")]) -> fromValue (Abstract.integer minInteger) - (Just (AST.Builtin "MIN"), [Just (AST.Builtin "LONGINT")]) -> fromValue (Abstract.integer minInteger) - (Just (AST.Builtin "MIN"), [Just (AST.Builtin "CARDINAL")]) -> fromValue (Abstract.integer 0) - (Just (AST.Builtin "MIN"), [Just (AST.Builtin "BITSET")]) -> fromValue (Abstract.integer minSet) - (Just (AST.Builtin "MIN"), [Just (AST.Builtin "REAL")]) -> fromValue (Abstract.real minReal) - (Just (AST.Builtin "MIN"), [Just (AST.Builtin "LONGREAL")]) -> fromValue (Abstract.real minReal) - _ -> SynCFExp{folded= Mapped (pos, Abstract.functionCall (getMapped $ folded (syn fn :: SynCFDesignator l)) - (foldedExp' . syn <$> getZipList args)), - foldedValue= Nothing} + synthesis _ (pos, _) _ (AST.FunctionCall fn args) + | Just (AST.Builtin "TRUNC") <- functionValue, + [Just (AST.Real x)] <- argValues = fromValue (Abstract.integer $ floor x) + | Just (AST.Builtin "FLOAT") <- functionValue, + [Just (AST.Integer x)] <- argValues = fromValue (Abstract.real $ fromIntegral x) + | Just (AST.Builtin "SIZE") <- functionValue, + [Just (AST.Builtin "CARDINAL")] <- argValues = fromValue (Abstract.integer $ toInteger $ sizeOf (0 :: Int)) + | Just (AST.Builtin "MAX") <- functionValue, + [Just (AST.Builtin "CARDINAL")] <- argValues = fromValue (Abstract.integer maxCardinal) + | Just (AST.Builtin "MAX") <- functionValue, + [Just (AST.Builtin "BISET")] <- argValues = fromValue (Abstract.integer maxSet) + | Just (AST.Builtin "MIN") <- functionValue, + [Just (AST.Builtin "CARDINAL")] <- argValues = fromValue (Abstract.integer 0) + | Just (AST.Builtin "MIN") <- functionValue, + [Just (AST.Builtin "BISET")] <- argValues = fromValue (Abstract.integer minSet) where fromValue v = Oberon.literalSynthesis (pos, v) - synthesis _ (pos, _) _ (AST.Literal val) = - SynCFExp{folded= Mapped (pos, Abstract.literal $ getMapped $ folded' $ syn val), - foldedValue= Just (getMapped $ folded' $ syn val)} + functionValue = snd <$> designatorValue (syn fn :: SynCFDesignator l) + argValues = (snd <$>) . foldedValue . syn <$> getZipList args + synthesis t (pos, self) (InhCF environment currMod) synthesized = + fromOberon (synthesis t (pos, toOberon self) (InhCF environment currMod) $ toOberon synthesized) + where fromJust3 :: forall f a (b :: * -> *) (c :: * -> *). Oberon.Abstract.Maybe3 f a b c -> f a b c + fromJust3 (Oberon.Abstract.Maybe3 Nothing) = + error ("Modula-2 expression cannot be converted to Oberon at " ++ show pos) + fromJust3 (Oberon.Abstract.Maybe3 (Just e)) = e + fromOberon :: SynCFExp Oberon.AST.Language l -> SynCFExp AST.Language l + fromOberon SynCFExp{folded= Mapped (pos', reportExpression), + foldedValue= reportValue} = + SynCFExp{folded= Mapped (pos', fromJust3 + $ Abstract.coExpression @Oberon.AST.Language + @(Abstract.WirthySubsetOf AST.Language) reportExpression), + foldedValue= reportValue} + toOberon :: Abstract.Expression AST.Language l f1 f2 -> Oberon.AST.Expression Oberon.AST.Language l f1 f2 + toOberon = fromJust3 . Abstract.coExpression @AST.Language @(Abstract.WirthySubsetOf Oberon.AST.Language) -maxCardinal, maxInteger, minInteger, maxInt32, minInt32, maxSet, minSet :: Integer +maxCardinal, maxInteger, maxSet, minSet :: Integer maxCardinal = 2 * maxInteger + 1 maxInteger = toInteger (maxBound :: Int) -minInteger = toInteger (minBound :: Int) -maxInt32 = toInteger (maxBound :: Int32) -minInt32 = toInteger (minBound :: Int32) maxSet = 63 minSet = 0 -doubleSize, floatSize, intSize, int32Size :: Integer -doubleSize = toInteger (sizeOf (0 :: Double)) -floatSize = toInteger (sizeOf (0 :: Float)) -intSize = toInteger (sizeOf (0 :: Int)) -int32Size = toInteger (sizeOf (0 :: Int32)) - -maxReal, minReal :: Double -maxReal = encodeFloat (floatRadix x - 1) (snd (floatRange x) - 1) - where x = 0 :: Double -minReal = encodeFloat (floatRadix x - 1) (fst (floatRange x)) - where x = 0 :: Double - -foldBinaryArithmetic :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, - Pretty (Abstract.Value l l Identity Identity)) => - (Int, ParsedLexemes, Int) - -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) - -> (forall n. Num n => n -> n -> n) - -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l -foldBinaryArithmetic pos@(start, ls, end) node op l r = - case join (foldValues <$> foldedValue l <*> foldedValue r) - of Just v -> Oberon.literalSynthesis v - Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), - foldedValue= Nothing} - where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) - foldBareValues :: AST.Value l l f f -> AST.Value l l f f -> Maybe (AST.Value l l f f) - foldValues (_, l') ((_, ls', _), r') = (,) (start, anyWhitespace ls ls', end) <$> foldBareValues l' r' - foldBareValues (AST.Integer l') (AST.Integer r') = Just (AST.Integer $ op l' r') - foldBareValues (AST.Real l') (AST.Real r') = Just (AST.Real $ op l' r') - foldBareValues (AST.Integer l') (AST.Real r') = Just (AST.Real $ op (fromIntegral l') r') - foldBareValues (AST.Real l') (AST.Integer r') = Just (AST.Real $ op l' (fromIntegral r')) - foldBareValues _ _ = Nothing - -foldBinaryFractional :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, - Pretty (Abstract.Value l l Identity Identity)) => - (Int, ParsedLexemes, Int) - -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) - -> (forall n. Fractional n => n -> n -> n) - -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l -foldBinaryFractional pos@(start, ls, end) node op l r = - case join (foldValues <$> foldedValue l <*> foldedValue r) - of Just v -> Oberon.literalSynthesis v - Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), - foldedValue= Nothing} - where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) - foldValues (_, AST.Real l') ((_, ls', _), AST.Real r') = Just ((start, anyWhitespace ls ls', end), - AST.Real $ op l' r') - foldValues _ _ = Nothing - -foldBinaryInteger :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, - Pretty (Abstract.Value l l Identity Identity)) => - (Int, ParsedLexemes, Int) - -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) - -> (forall n. Integral n => n -> n -> n) - -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l -foldBinaryInteger pos@(start, ls, end) node op l r = - case join (foldValues <$> foldedValue l <*> foldedValue r) - of Just v -> Oberon.literalSynthesis v - Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), - foldedValue= Nothing} - where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) - foldValues (_, AST.Integer l') ((_, ls', _), AST.Integer r') = Just ((start, anyWhitespace ls ls', end), - AST.Integer $ op l' r') - foldValues _ _ = Nothing - -foldBinaryBoolean :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, - Pretty (Abstract.Value l l Identity Identity)) => - (Int, ParsedLexemes, Int) - -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) - -> (Bool -> Bool -> Bool) - -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l -foldBinaryBoolean pos@(start, ls, end) node op l r = - case join (foldValues <$> foldedValue l <*> foldedValue r) - of Just v -> Oberon.literalSynthesis v - Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), - foldedValue= Nothing} - where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) - foldValues (_, AST.Boolean l') ((_, ls', _), AST.Boolean r') = Just ((start, anyWhitespace ls ls', end), - AST.Boolean $ op l' r') - foldValues _ _ = Nothing - instance (Abstract.Modula2 l, Ord (Abstract.QualIdent l), v ~ Abstract.Value l l Placed Placed, Atts (Inherited (Auto ConstantFold)) (Abstract.Expression l l Sem Sem) ~ InhCF l, Atts (Inherited (Auto ConstantFold)) (Abstract.Designator l l Sem Sem) ~ InhCF l, @@ -412,32 +240,3 @@ SynthesizedField "designatorValue" (Maybe (Placed v)) (Auto ConstantFold) (AST.Designator l l) Sem Placed where synthesizedField _ _ (pos, AST.Variable q) inheritance _ = (,) pos <$> join (Map.lookup q $ env inheritance) synthesizedField _ _ _ _ _ = Nothing - --- * More boring Transformation.Functor instances, TH candidates -instance Ord (Abstract.QualIdent l) => Transformation.At (Auto ConstantFold) (Modules l Sem Sem) where - ($) = AG.applyDefault snd - --- * Unsafe Rank2 AST instances - -$(do l <- varT <$> newName "l" - mconcat <$> mapM (\g-> Transformation.Full.TH.deriveUpFunctor (conT ''Auto `appT` conT ''ConstantFold) $ conT g `appT` l `appT` l) - [''AST.Type, ''AST.FieldList, - ''AST.ProcedureHeading, - ''AST.Expression, ''AST.Designator, - ''AST.Statement, ''AST.Variant]) - -$(do let sem = [t|Semantics (Auto ConstantFold)|] - let inst g = [d| instance Attribution (Auto ConstantFold) ($g l l) Sem Placed => - Transformation.At (Auto ConstantFold) ($g l l $sem $sem) - where ($) = AG.applyDefault snd |] - mconcat <$> mapM (inst . conT) - [''AST.Module, ''AST.ProcedureHeading, ''AST.Type, ''AST.FieldList, - ''AST.Statement, ''AST.Expression, ''AST.Designator, ''AST.Variant]) - -$(do full <- varT <$> newName "full" - l <- varT <$> newName "l" - Transformation.Full.TH.deriveUpFunctor [t| (Auto ConstantFold) |] [t| AST.Declaration $full $l $l |]) - -instance Attribution (Auto ConstantFold) (AST.Declaration full l l) Sem Placed - => Transformation.At (Auto ConstantFold) (AST.Declaration full l l Sem Sem) where - ($) = AG.applyDefault snd diff --git a/src/Language/Modula2/Grammar.hs b/src/Language/Modula2/Grammar.hs --- a/src/Language/Modula2/Grammar.hs +++ b/src/Language/Modula2/Grammar.hs @@ -10,6 +10,7 @@ import Control.Monad (guard, void) import Data.Char (isAlphaNum, isDigit, isHexDigit, isLetter, isOctDigit, isSpace) import Data.List.NonEmpty (NonEmpty, toList) +import Data.Ord (Down) import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Text (Text, unpack) @@ -19,6 +20,7 @@ import Text.Parser.Combinators (sepBy, sepBy1, sepByNonEmpty, try) import Text.Parser.Token (braces, brackets, parens) +import qualified Rank2 import qualified Rank2.TH import Language.Oberon.Grammar (Lexeme(..), TokenType(..), ParsedLexemes(Trailing)) @@ -103,13 +105,15 @@ compilationUnit :: p (NodeWrap (Abstract.Module l l f f)) } -type NodeWrap = (,) (Position, ParsedLexemes, Position) +type NodeWrap = (,) (Down Int, ParsedLexemes, Down Int) +$(Rank2.TH.deriveAll ''Modula2Grammar) + modula2grammar :: Grammar (Modula2Grammar AST.Language NodeWrap) Parser Text modula2grammar = fixGrammar grammar -- | All the productions of Modula-2 grammar -grammar :: forall l g. (Abstract.Modula2 l, LexicalParsing (Parser g Text)) +grammar :: forall l g. (Abstract.Modula2 l, Rank2.Apply g, LexicalParsing (Parser g Text)) => GrammarBuilder (Modula2Grammar l NodeWrap) g Parser Text grammar g@Modula2Grammar{..} = g{ ident = identifier, @@ -301,17 +305,17 @@ <* lift ([[Token Keyword s]], ())) ("keyword " <> show s) -comment :: Parser g Text Text +comment :: Rank2.Apply g => Parser g Text Text comment = try (string "(*" <> concatMany (comment <<|> notFollowedBy (string "*)") *> anyToken <> takeCharsWhile isCommentChar) <> string "*)") where isCommentChar c = c /= '*' && c /= '(' -whiteSpace :: LexicalParsing (Parser g Text) => Parser g Text () +whiteSpace :: Rank2.Apply g => LexicalParsing (Parser g Text) => Parser g Text () whiteSpace = spaceChars *> skipMany (lexicalComment *> spaceChars) "whitespace" where spaceChars = (takeCharsWhile1 isSpace >>= \ws-> lift ([[WhiteSpace ws]], ())) <<|> pure () -wrap :: Parser g Text a -> Parser g Text (NodeWrap a) +wrap :: Rank2.Apply g => Parser g Text a -> Parser g Text (NodeWrap a) wrap = (\p-> liftA3 surround getSourcePos p getSourcePos) . tmap store . ((,) (Trailing []) <$>) where surround start (lexemes, p) end = ((start, lexemes, end), p) store (wss, (Trailing ws', a)) = (mempty, (Trailing $ ws' <> concat wss, a)) @@ -333,5 +337,3 @@ "QUALIFIED", "RECORD", "REPEAT", "RETURN", "SET", "THEN", "TO", "TYPE", "UNTIL", "VAR", "WHILE", "WITH"] - -$(Rank2.TH.deriveAll ''Modula2Grammar) diff --git a/src/Language/Modula2/ISO/AST.hs b/src/Language/Modula2/ISO/AST.hs --- a/src/Language/Modula2/ISO/AST.hs +++ b/src/Language/Modula2/ISO/AST.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, DeriveDataTypeable, FlexibleInstances, GADTs, KindSignatures, InstanceSigs, +{-# LANGUAGE DataKinds, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GADTs, KindSignatures, InstanceSigs, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies #-} {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} diff --git a/src/Language/Modula2/ISO/ConstantFolder.hs b/src/Language/Modula2/ISO/ConstantFolder.hs --- a/src/Language/Modula2/ISO/ConstantFolder.hs +++ b/src/Language/Modula2/ISO/ConstantFolder.hs @@ -1,13 +1,12 @@ {-# LANGUAGE DataKinds, DuplicateRecordFields, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, - ScopedTypeVariables, TemplateHaskell, TypeApplications, TypeFamilies, UndecidableInstances #-} + ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} -- | The main export of this module is the function 'foldConstants' that folds the constants in an ISO Modula-2 AST -- using an attribute grammar. Other exports are helper functions and attribute types that can be reused for other -- languages or attribute grammars. -module Language.Modula2.ISO.ConstantFolder (foldConstants, InhCF, - SynCF(..), SynCFDesignator(..), SynCFExp(..), SynCFMod', Environment) where +module Language.Modula2.ISO.ConstantFolder (foldConstants, ConstantFold, Environment) where import Control.Applicative (liftA2, ZipList(ZipList, getZipList)) import Control.Arrow (first) @@ -25,7 +24,6 @@ import Data.Semigroup (Semigroup(..)) import qualified Data.Text as Text import Foreign.Storable (sizeOf) -import Language.Haskell.TH (appT, conT, varT, varE, newName) import Data.Text.Prettyprint.Doc (Pretty) import qualified Rank2 @@ -52,12 +50,8 @@ import Language.Oberon.ConstantFolder (ConstantFold(ConstantFold), Placed, Sem, Environment, InhCF(..), InhCFRoot(..), SynCF(..), SynCF', SynCFRoot(..), SynCFMod(..), SynCFMod', SynCFExp(..), SynCFDesignator(..), - folded', foldedExp, foldedExp') -import Language.Modula2.ConstantFolder (foldBinaryArithmetic, foldBinaryBoolean, - foldBinaryFractional, foldBinaryInteger, - maxCardinal, maxInteger, minInteger, maxInt32, minInt32, maxSet, minSet, - doubleSize, floatSize, intSize, int32Size, - maxReal, minReal) + anyWhitespace, folded', foldedExp, foldedExp') +import Language.Modula2.ConstantFolder () -- | Fold the constants in the given collection of Modula-2 modules (a 'Map' of modules keyed by module name). It uses -- the constant declarations from the modules as well as the given 'Environment' of predefined constants and @@ -107,25 +101,25 @@ ~(Modules fs) <*> ~(Modules ms) = Modules (Map.intersectionWith Rank2.apply fs ms) -- * Boring attribute types -type instance Atts (Synthesized (Auto ConstantFold)) (Modules l _ _) = SynCFRoot (Modules l Placed Identity) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Block λ l _ _) = SynCFMod' l (AST.Block l l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Declaration full λ l _ _) = SynCFMod' l (AST.Declaration full l l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.AddressedIdent λ l _ _) = SynCF' (AST.AddressedIdent l l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Type λ l _ _) = SynCF' (AST.Type l l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Expression λ l _ _) = SynCFExp λ l -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Item λ l _ _) = SynCF' (AST.Item l l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Statement λ l _ _) = SynCF' (AST.Statement l l) -type instance Atts (Synthesized (Auto ConstantFold)) (AST.Variant λ l _ _) = SynCF' (AST.Variant l l) +type instance Atts (Synthesized ConstantFold) (Modules l _ _) = SynCFRoot (Modules l Placed Identity) +type instance Atts (Synthesized ConstantFold) (AST.Block λ l _ _) = SynCFMod' l (AST.Block l l) +type instance Atts (Synthesized ConstantFold) (AST.Declaration full λ l _ _) = SynCFMod' l (AST.Declaration full l l) +type instance Atts (Synthesized ConstantFold) (AST.AddressedIdent λ l _ _) = SynCF' (AST.AddressedIdent l l) +type instance Atts (Synthesized ConstantFold) (AST.Type λ l _ _) = SynCF' (AST.Type l l) +type instance Atts (Synthesized ConstantFold) (AST.Expression λ l _ _) = SynCFExp λ l +type instance Atts (Synthesized ConstantFold) (AST.Item λ l _ _) = SynCF' (AST.Item l l) +type instance Atts (Synthesized ConstantFold) (AST.Statement λ l _ _) = SynCF' (AST.Statement l l) +type instance Atts (Synthesized ConstantFold) (AST.Variant λ l _ _) = SynCF' (AST.Variant l l) -type instance Atts (Inherited (Auto ConstantFold)) (Modules l _ _) = InhCFRoot l -type instance Atts (Inherited (Auto ConstantFold)) (AST.Block λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Declaration full λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.AddressedIdent λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Type λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Item λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Expression λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Statement λ l _ _) = InhCF λ -type instance Atts (Inherited (Auto ConstantFold)) (AST.Variant λ l _ _) = InhCF λ +type instance Atts (Inherited ConstantFold) (Modules l _ _) = InhCFRoot l +type instance Atts (Inherited ConstantFold) (AST.Block λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Declaration full λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.AddressedIdent λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Type λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Item λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Expression λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Statement λ l _ _) = InhCF l +type instance Atts (Inherited ConstantFold) (AST.Variant λ l _ _) = InhCF l wrap :: a -> Mapped Placed a wrap = Mapped . (,) (0, Trailing [], 0) @@ -191,11 +185,7 @@ synthesizedField _ _ _ _ _ = mempty instance (Abstract.Nameable l, Ord (Abstract.QualIdent l), - Abstract.QualIdent l ~ AST.QualIdent l, Abstract.Value l ~ AST.Value l, - λ ~ AST.Language, --- Abstract.QualIdent Report.Language ~ AST.QualIdent l, - Coercible (Abstract.QualIdent Report.Language) (AST.QualIdent l), - Coercible (Abstract.Value Report.Language Report.Language) (AST.Value l l), + Abstract.Expression λ ~ AST.Expression AST.Language, Abstract.QualIdent λ ~ AST.QualIdent AST.Language, InhCF l ~ InhCF λ, Pretty (AST.Value l l Identity Identity), Atts (Synthesized (Auto ConstantFold)) (Abstract.Expression l l Sem Sem) ~ SynCFExp l l, @@ -215,8 +205,7 @@ SynCFExp{folded= Mapped (pos, Abstract.set t (getMapped . folded' . syn <$> getZipList elements)), foldedValue= Nothing} synthesis t (pos, self) (InhCF environment currMod) synthesized = - fromReport (synthesis t (pos, toReport self) (InhCF (coerce <$> Map.mapKeysMonotonic coerce environment) currMod) - $ toReport synthesized) + fromReport (synthesis t (pos, toReport self) (InhCF environment currMod) $ toReport synthesized) where fromJust :: forall f a (b :: * -> *) (c :: * -> *). Oberon.Abstract.Maybe3 f a b c -> f a b c fromJust (Oberon.Abstract.Maybe3 Nothing) = error ("Modula-2 expression cannot be converted from ISO to Report at " ++ show pos) @@ -230,27 +219,19 @@ toReport :: Abstract.Expression AST.Language l f1 f2 -> Report.Expression Report.Language l f1 f2 toReport s = fromJust (coExpression @AST.Language @(Abstract.WirthySubsetOf Report.Language) s) --- * More boring Transformation.Functor instances, TH candidates -instance Ord (Abstract.QualIdent l) => Transformation.At (Auto ConstantFold) (Modules l Sem Sem) where - ($) = AG.applyDefault snd --- * Unsafe Rank2 AST instances - -$(do l <- varT <$> newName "l" - mconcat <$> mapM (\g-> Transformation.Full.TH.deriveUpFunctor (conT ''Auto `appT` conT ''ConstantFold) $ conT g `appT` l `appT` l) - [''AST.Block, ''AST.AddressedIdent, ''AST.Type, ''AST.Expression, ''AST.Statement, ''AST.Item, ''AST.Variant]) - -$(do let sem = [t|Semantics (Auto ConstantFold)|] - let inst g = [d| instance Attribution (Auto ConstantFold) ($g l l) Sem Placed => - Transformation.At (Auto ConstantFold) ($g l l $sem $sem) - where ($) = AG.applyDefault snd |] - mconcat <$> mapM (inst . conT) - [''AST.Block, ''AST.AddressedIdent, ''AST.Type, ''AST.Statement, ''AST.Expression, ''AST.Item, ''AST.Variant]) - -$(do full <- varT <$> newName "full" - l <- varT <$> newName "l" - Transformation.Full.TH.deriveUpFunctor [t| (Auto ConstantFold) |] [t| AST.Declaration $full $l $l |]) - -instance Attribution (Auto ConstantFold) (AST.Declaration full l l) Sem Placed - => Transformation.At (Auto ConstantFold) (AST.Declaration full l l Sem Sem) where - ($) = AG.applyDefault snd +foldBinaryInteger :: forall λ l f. (f ~ Placed, Abstract.Value l ~ AST.Value l, Abstract.Wirthy λ, + Pretty (Abstract.Value l l Identity Identity)) => + (Int, ParsedLexemes, Int) + -> (f (Abstract.Expression l l f f) -> f (Abstract.Expression l l f f) -> Abstract.Expression λ l f f) + -> (forall n. Integral n => n -> n -> n) + -> SynCFExp l l -> SynCFExp l l -> SynCFExp λ l +foldBinaryInteger pos@(start, ls, end) node op l r = + case join (foldValues <$> foldedValue l <*> foldedValue r) + of Just v -> Oberon.ConstantFolder.literalSynthesis v + Nothing -> SynCFExp{folded= Mapped (pos, node (foldedExp' l) (foldedExp' r)), + foldedValue= Nothing} + where foldValues :: Placed (AST.Value l l f f) -> Placed (AST.Value l l f f) -> Maybe (Placed (AST.Value l l f f)) + foldValues (_, AST.Integer l') ((_, ls', _), AST.Integer r') = Just ((start, anyWhitespace ls ls', end), + AST.Integer $ op l' r') + foldValues _ _ = Nothing diff --git a/src/Language/Modula2/ISO/Grammar.hs b/src/Language/Modula2/ISO/Grammar.hs --- a/src/Language/Modula2/ISO/Grammar.hs +++ b/src/Language/Modula2/ISO/Grammar.hs @@ -46,8 +46,10 @@ arrayPart :: p (ISO.Abstract.Item l l f f), structureComponent :: p (f (Abstract.Expression l l f f))} +$(Rank2.TH.deriveAll ''ISOMixin) + -- | The new grammar productions in the ISO specification -isoMixin :: (ISO.Abstract.Modula2 l, LexicalParsing (Parser g Text)) +isoMixin :: (ISO.Abstract.Modula2 l, Rank2.Apply g, LexicalParsing (Parser g Text)) => ReportGrammar.Modula2Grammar l ReportGrammar.NodeWrap (Parser g Text) -> ISOMixin l ReportGrammar.NodeWrap (Parser g Text) -> ISOMixin l ReportGrammar.NodeWrap (Parser g Text) @@ -81,7 +83,7 @@ modula2ISOgrammar = fixGrammar isoGrammar -- | All the productions of the ISO Modula-2 grammar -isoGrammar :: forall l g. (ISO.Abstract.Modula2 l, LexicalParsing (Parser g Text)) +isoGrammar :: forall l g. (ISO.Abstract.Modula2 l, Rank2.Apply g, LexicalParsing (Parser g Text)) => GrammarBuilder (ISOGrammar l) g Parser Text isoGrammar (Rank2.Pair iso@ISOMixin{..} report@ReportGrammar.Modula2Grammar{..}) = Rank2.Pair (isoMixin report iso) $ @@ -131,8 +133,6 @@ ("keyword " <> show s) reservedWords = ReportGrammar.reservedWords <> ["EXCEPT", "FINALLY", "FORWARD", "PACKEDSET", "REM", "RETRY"] - -$(Rank2.TH.deriveAll ''ISOMixin) {- compilation module = program module | definition module | implementation module,