packages feed

language-Modula2 0.1 → 0.1.2

raw patch · 9 files changed

+138/−347 lines, 9 filesdep ~deep-transformationsdep ~grammatical-parsersdep ~input-parsers

Dependency ranges changed: deep-transformations, grammatical-parsers, input-parsers, template-haskell, text

Files

CHANGELOG.md view
@@ -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.
language-Modula2.cabal view
@@ -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
src/Language/Modula2.hs view
@@ -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 ()
src/Language/Modula2/AST.hs view
@@ -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 #-}
src/Language/Modula2/ConstantFolder.hs view
@@ -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
src/Language/Modula2/Grammar.hs view
@@ -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)
src/Language/Modula2/ISO/AST.hs view
@@ -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 #-}
src/Language/Modula2/ISO/ConstantFolder.hs view
@@ -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
src/Language/Modula2/ISO/Grammar.hs view
@@ -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,