fortran-src 0.10.2 → 0.11.0

raw patch · 57 files changed

+2398/−70 lines, 57 filesdep +singletonsdep +singletons-basedep +singletons-thdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: singletons, singletons-base, singletons-th, vector-sized

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• README.md +1/−1
• app/Main.hs +1/−1
• fortran-src.cabal +109/−27
• src/Language/Fortran/AST.hs +28/−0
• src/Language/Fortran/AST/Literal/Complex.hs +8/−0
• src/Language/Fortran/Analysis.hs +14/−2
• src/Language/Fortran/Analysis/BBlocks.hs +6/−2
• src/Language/Fortran/Analysis/DataFlow.hs +0/−1
• src/Language/Fortran/Analysis/ModGraph.hs +0/−2
• src/Language/Fortran/Analysis/Renaming.hs +0/−2
• src/Language/Fortran/Analysis/SemanticTypes.hs +0/−1
• src/Language/Fortran/Analysis/Types.hs +11/−4
• src/Language/Fortran/Parser.hs +36/−2
• src/Language/Fortran/Parser/Fixed/Lexer.x +29/−10
• src/Language/Fortran/Parser/Monad.hs +0/−1
• src/Language/Fortran/Repr.hs +108/−0
• src/Language/Fortran/Repr/Compat/Natural.hs +29/−0
• src/Language/Fortran/Repr/Eval/Common.hs +23/−0
• src/Language/Fortran/Repr/Eval/Type.hs +16/−0
• src/Language/Fortran/Repr/Eval/Value.hs +415/−0
• src/Language/Fortran/Repr/Eval/Value/Op.hs +144/−0
• src/Language/Fortran/Repr/Eval/Value/Op/Some.hs +177/−0
• src/Language/Fortran/Repr/Tmp.hs +46/−0
• src/Language/Fortran/Repr/Type.hs +10/−0
• src/Language/Fortran/Repr/Type/Array.hs +21/−0
• src/Language/Fortran/Repr/Type/Scalar.hs +34/−0
• src/Language/Fortran/Repr/Type/Scalar/Common.hs +63/−0
• src/Language/Fortran/Repr/Type/Scalar/Complex.hs +31/−0
• src/Language/Fortran/Repr/Type/Scalar/Int.hs +87/−0
• src/Language/Fortran/Repr/Type/Scalar/Real.hs +43/−0
• src/Language/Fortran/Repr/Type/Scalar/String.hs +42/−0
• src/Language/Fortran/Repr/Util.hs +11/−0
• src/Language/Fortran/Repr/Value.hs +25/−0
• src/Language/Fortran/Repr/Value/Array.hs +5/−0
• src/Language/Fortran/Repr/Value/Array/Machine.hs +106/−0
• src/Language/Fortran/Repr/Value/Common.hs +19/−0
• src/Language/Fortran/Repr/Value/Machine.hs +14/−0
• src/Language/Fortran/Repr/Value/Scalar.hs +18/−0
• src/Language/Fortran/Repr/Value/Scalar/Common.hs +20/−0
• src/Language/Fortran/Repr/Value/Scalar/Complex.hs +47/−0
• src/Language/Fortran/Repr/Value/Scalar/Int.hs +5/−0
• src/Language/Fortran/Repr/Value/Scalar/Int/Idealized.hs +88/−0
• src/Language/Fortran/Repr/Value/Scalar/Int/Machine.hs +215/−0
• src/Language/Fortran/Repr/Value/Scalar/Logical.hs +5/−0
• src/Language/Fortran/Repr/Value/Scalar/Logical/Idealized.hs +13/−0
• src/Language/Fortran/Repr/Value/Scalar/Logical/Machine.hs +27/−0
• src/Language/Fortran/Repr/Value/Scalar/Machine.hs +50/−0
• src/Language/Fortran/Repr/Value/Scalar/Real.hs +106/−0
• src/Language/Fortran/Repr/Value/Scalar/String.hs +63/−0
• src/Language/Fortran/Transformation/Disambiguation/Function.hs +0/−2
• src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs +0/−2
• src/Language/Fortran/Util/ModFile.hs +0/−2
• test/Language/Fortran/Analysis/DataFlowSpec.hs +0/−1
• test/Language/Fortran/Parser/Fixed/LexerSpec.hs +6/−2
• test/Language/Fortran/PrettyPrintSpec.hs +0/−1
• test/Language/Fortran/RewriterSpec.hs +3/−4

@@ -1,3 +1,23 @@+### 0.11.0 (Oct 10, 2022)+  * add strong Fortran value & type representation at `Language.Fortran.Repr`+    (currently unused) (#235, @raehik)+    * operations are accurate to actual Fortran compiler behaviour e.g. integers+      are stored fixed-width based on kind, so overflow behaviour is free+    * can recover a value's precise type (e.g. `INTEGER(8)`, including kind) via+      pattern matching+  * bump minimum compiler version to GHC 9.0+  * improved comment handling in fixed form lexer: parse more comment syntax,+    case sensitive, parse beyond column 72 (#237, @RaoulHC)+  * allow `ExpDataRef` constructor in `varName` (fixes a crash in type analysis+    #238)+  * add `Annotated`, `Spanned` instances for intermediate AST data type+    `ArgumentExpression`+  * export statement-level "pre-prepared" parsers (previously, you would have to+    define the parser yourself using parser utils and the Happy parser export)+  * export `Language.Fortran.Parser.byVerFromFilename :: Parser (ProgramFile+    A0)`, a replacement for the removed+    `Language.Fortran.Parser.Any.fortranParser`+ ### 0.10.2 (Aug 18, 2022)   * fix missing parentheses when pretty printing certain syntax #233   * fix missing export of `ParseErrorSimple` in `Parser`

@@ -62,7 +62,7 @@ Haskell library dependencies are listed in `package.yaml`. fortran-src supports building with Stack or Cabal. -fortran-src supports **GHC 8.4 through GHC 9.0**. We regularly test at least the+fortran-src supports **GHC 9.0 through GHC 9.2**. We regularly test at least the minimum and maximum supported GHCs. Releases prior to/newer than those may have issues. We welcome fixes that would let us support a wider range of compilers. 

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Main ( main ) where

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           fortran-src-version:        0.10.2+version:        0.11.0 synopsis:       Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @<https://hackage.haskell.org/package/camfort CamFort>@ project, which uses fortran-src as its front end. category:       Language@@ -21,7 +21,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC >= 8.4+    GHC >= 9.0 extra-source-files:     README.md     CHANGELOG.md@@ -94,6 +94,40 @@       Language.Fortran.Parser.Monad       Language.Fortran.Parser.ParserUtils       Language.Fortran.PrettyPrint+      Language.Fortran.Repr+      Language.Fortran.Repr.Compat.Natural+      Language.Fortran.Repr.Eval.Common+      Language.Fortran.Repr.Eval.Type+      Language.Fortran.Repr.Eval.Value+      Language.Fortran.Repr.Eval.Value.Op+      Language.Fortran.Repr.Eval.Value.Op.Some+      Language.Fortran.Repr.Tmp+      Language.Fortran.Repr.Type+      Language.Fortran.Repr.Type.Array+      Language.Fortran.Repr.Type.Scalar+      Language.Fortran.Repr.Type.Scalar.Common+      Language.Fortran.Repr.Type.Scalar.Complex+      Language.Fortran.Repr.Type.Scalar.Int+      Language.Fortran.Repr.Type.Scalar.Real+      Language.Fortran.Repr.Type.Scalar.String+      Language.Fortran.Repr.Util+      Language.Fortran.Repr.Value+      Language.Fortran.Repr.Value.Array+      Language.Fortran.Repr.Value.Array.Machine+      Language.Fortran.Repr.Value.Common+      Language.Fortran.Repr.Value.Machine+      Language.Fortran.Repr.Value.Scalar+      Language.Fortran.Repr.Value.Scalar.Common+      Language.Fortran.Repr.Value.Scalar.Complex+      Language.Fortran.Repr.Value.Scalar.Int+      Language.Fortran.Repr.Value.Scalar.Int.Idealized+      Language.Fortran.Repr.Value.Scalar.Int.Machine+      Language.Fortran.Repr.Value.Scalar.Logical+      Language.Fortran.Repr.Value.Scalar.Logical.Idealized+      Language.Fortran.Repr.Value.Scalar.Logical.Machine+      Language.Fortran.Repr.Value.Scalar.Machine+      Language.Fortran.Repr.Value.Scalar.Real+      Language.Fortran.Repr.Value.Scalar.String       Language.Fortran.Rewriter       Language.Fortran.Rewriter.Internal       Language.Fortran.Transformation.Disambiguation.Function@@ -111,13 +145,12 @@   hs-source-dirs:       src   default-extensions:+      TupleSections       EmptyCase-      FlexibleContexts-      FlexibleInstances-      InstanceSigs-      MultiParamTypeClasses-      PolyKinds       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces       DerivingStrategies       StandaloneDeriving       DeriveAnyClass@@ -127,8 +160,21 @@       DeriveFoldable       DeriveTraversable       DeriveLift-      BangPatterns-      TupleSections+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes+      TypeApplications+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+      BinaryLiterals+      ScopedTypeVariables+      TypeOperators   ghc-options: -Wall -fno-warn-tabs   build-tools:       alex >=3.1@@ -147,12 +193,16 @@     , filepath ==1.4.*     , mtl >=2.2 && <3     , pretty >=1.1 && <2+    , singletons >=3.0+    , singletons-base >=3.0+    , singletons-th >=3.0     , temporary >=1.2 && <1.4     , text >=1.2 && <2     , uniplate >=1.6 && <2+    , vector-sized >=1.5.0 && <1.6+  default-language: Haskell2010   if os(windows)     cpp-options: -DFS_DISABLE_WIN_BROKEN_TESTS-  default-language: Haskell2010  executable fortran-src   main-is: Main.hs@@ -161,13 +211,12 @@   hs-source-dirs:       app   default-extensions:+      TupleSections       EmptyCase-      FlexibleContexts-      FlexibleInstances-      InstanceSigs-      MultiParamTypeClasses-      PolyKinds       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces       DerivingStrategies       StandaloneDeriving       DeriveAnyClass@@ -177,8 +226,21 @@       DeriveFoldable       DeriveTraversable       DeriveLift-      BangPatterns-      TupleSections+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes+      TypeApplications+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+      BinaryLiterals+      ScopedTypeVariables+      TypeOperators   ghc-options: -Wall -fno-warn-tabs   build-depends:       GenericPretty >=1.2.2 && <2@@ -195,12 +257,16 @@     , fortran-src     , mtl >=2.2 && <3     , pretty >=1.1 && <2+    , singletons >=3.0+    , singletons-base >=3.0+    , singletons-th >=3.0     , temporary >=1.2 && <1.4     , text >=1.2 && <2     , uniplate >=1.6 && <2+    , vector-sized >=1.5.0 && <1.6+  default-language: Haskell2010   if os(windows)     cpp-options: -DFS_DISABLE_WIN_BROKEN_TESTS-  default-language: Haskell2010  test-suite spec   type: exitcode-stdio-1.0@@ -237,13 +303,12 @@   hs-source-dirs:       test   default-extensions:+      TupleSections       EmptyCase-      FlexibleContexts-      FlexibleInstances-      InstanceSigs-      MultiParamTypeClasses-      PolyKinds       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces       DerivingStrategies       StandaloneDeriving       DeriveAnyClass@@ -253,8 +318,21 @@       DeriveFoldable       DeriveTraversable       DeriveLift-      BangPatterns-      TupleSections+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes+      TypeApplications+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+      BinaryLiterals+      ScopedTypeVariables+      TypeOperators   ghc-options: -Wall   build-tool-depends:       hspec-discover:hspec-discover@@ -275,9 +353,13 @@     , hspec >=2.2 && <3     , mtl >=2.2 && <3     , pretty >=1.1 && <2+    , singletons >=3.0+    , singletons-base >=3.0+    , singletons-th >=3.0     , temporary >=1.2 && <1.4     , text >=1.2 && <2     , uniplate >=1.6 && <2+    , vector-sized >=1.5.0 && <1.6+  default-language: Haskell2010   if os(windows)     cpp-options: -DFS_DISABLE_WIN_BROKEN_TESTS-  default-language: Haskell2010

@@ -674,11 +674,36 @@   , argumentExpr :: ArgumentExpression a   } deriving stock (Eq, Show, Data, Generic, Functor) +-- | Extra data type to disambiguate between plain variable arguments and+--   expression arguments (due to apparent behaviour of some Fortran compilers+--   to treat these differently).+--+-- Note the 'Annotated' and 'Spanned' instances pass to the inner 'Expression'+-- for 'ArgExpr'. data ArgumentExpression a   = ArgExpr              (Expression a)   | ArgExprVar a SrcSpan Name   deriving stock (Eq, Show, Data, Generic, Functor) +instance Annotated ArgumentExpression where+    getAnnotation = \case+      ArgExpr    e         -> getAnnotation e+      ArgExprVar a _ss _nm -> a+    setAnnotation a = \case+      ArgExpr    e         -> ArgExpr (setAnnotation a e)+      ArgExprVar _a ss nm  -> ArgExprVar a ss nm+    modifyAnnotation f = \case+      ArgExpr    e        -> ArgExpr (modifyAnnotation f e)+      ArgExprVar a ss nm  -> ArgExprVar (f a) ss nm++instance Spanned (ArgumentExpression a) where+    getSpan = \case+      ArgExpr    e         -> getSpan e+      ArgExprVar _a ss _nm -> ss+    setSpan ss = \case+      ArgExpr    e        -> ArgExpr (setSpan ss e)+      ArgExprVar a _ss nm -> ArgExprVar a ss nm+ argExprNormalize :: ArgumentExpression a -> Expression a argExprNormalize = \case ArgExpr         e -> e                          ArgExprVar a ss v -> ExpValue a ss (ValVariable v)@@ -871,6 +896,9 @@   deriving stock (Eq, Show, Data, Generic, Functor)  -- | Values and literals.+--+-- Note that 'KindParam' kind parameters may only be available on certain+-- Fortran parsers. The fixed form parsers (F77, F66) may not parse them. data Value a   = ValInteger           String  (Maybe (KindParam a))   -- ^ The string representation of an integer literal

@@ -58,3 +58,11 @@ instance Annotated       ComplexPart instance SecondParameter (ComplexPart a) SrcSpan instance Spanned         (ComplexPart a)++-- | Is the given COMPLEX literal "pure", i.e. does it have no named constant+--   components?+complexLitIsPure :: ComplexLit a -> Bool+complexLitIsPure c =+    check (complexLitRealPart c) && check (complexLitImagPart c)+  where check = \case ComplexPartNamed{} -> False+                      _                  -> True

@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- |@@ -170,7 +169,16 @@ isNamedExpression (ExpValue _ _ (ValIntrinsic _)) = True isNamedExpression _                               = False --- | Obtain either uniqueName or source name from an ExpValue variable.+-- | Obtain either 'uniqueName' or 'sourceName' from an 'ExpValue' variable, or+--   an 'ExpDataRef'.+--+-- Precedence is as follows:+--+--   * if 'uniqueName' is present, it is returned+--   * else if 'sourceName' is present, it is returned+--   * else the variable name itself is returned+--+-- Crashes on 'Expression's which don't define a variable. varName :: Expression (Analysis a) -> Name varName (ExpValue Analysis { uniqueName = Just n } _ ValVariable{})  = n varName (ExpValue Analysis { sourceName = Just n } _ ValVariable{})  = n@@ -178,6 +186,10 @@ varName (ExpValue Analysis { uniqueName = Just n } _ ValIntrinsic{}) = n varName (ExpValue Analysis { sourceName = Just n } _ ValIntrinsic{}) = n varName (ExpValue _ _ (ValIntrinsic n))                              = n++-- | Recursively apply to the left for data refs e.g. @var%field@ -> @var@+varName (ExpDataRef _ _ e _) = varName e+ varName _                                                            = error "Use of varName on non-variable."  -- | Obtain the source name from an ExpValue variable.

@@ -1,6 +1,5 @@ -- | Analyse a program file and create basic blocks. -{-# LANGUAGE ScopedTypeVariables #-} module Language.Fortran.Analysis.BBlocks   ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap, ASTBlockNode, ASTExprNode   , genSuperBBGr, SuperBBGr(..), showSuperBBGr, superBBGrToDOT, findLabeledBBlock, showBlock )@@ -105,12 +104,17 @@         _                             -> b       where i = insLabel $ getAnnotation b +    mfill+        :: forall f. (Data (f (Analysis a)))+        => Maybe ASTBlockNode -> Maybe (f (Analysis a)) -> Maybe (f (Analysis a))     mfill i  = fmap (fill i)      fillCaseClause i (rs, b) = (fill i rs, b)     fillIf i (e, b) = (fill i e, b) -    fill :: forall f. (Data (f (Analysis a))) => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a)+    fill+        :: forall f. (Data (f (Analysis a)))+        => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a)     fill Nothing  = id     fill (Just i) = transform perIndex       where

@@ -1,6 +1,5 @@ -- | Dataflow analysis to be applied once basic block analysis is complete. -{-# LANGUAGE ScopedTypeVariables #-} module Language.Fortran.Analysis.DataFlow   ( dominators, iDominators, DomMap, IDomMap   , postOrder, revPostOrder, preOrder, revPreOrder, OrderF

@@ -1,5 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}- -- | Generate a module use-graph. module Language.Fortran.Analysis.ModGraph   (genModGraph, ModGraph(..), ModOrigin(..), modGraphToDOT, takeNextMods, delModNodes)

@@ -1,5 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}- -- | -- Analyse variables/function names and produce unique names that can -- be used to replace the original names while maintaining program

@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}  module Language.Fortran.Analysis.SemanticTypes where

@@ -1,5 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}- module Language.Fortran.Analysis.Types   ( analyseTypes   , analyseTypesWithEnv@@ -240,13 +238,22 @@ statement (StExternal _ _ varAList) = do   let vars = aStrip varAList   mapM_ (recordCType CTExternal . varName) vars-statement (StExpressionAssign _ _ (ExpSubscript _ _ v ixAList) _)+statement (StExpressionAssign _ ss (ExpSubscript _ _ v ixAList) _)   --  | any (not . isIxSingle) (aStrip ixAList) = recordCType CTArray (varName v)  -- it's an array (or a string?) FIXME   | all isIxSingle (aStrip ixAList) = do     mIDType <- getExprRecordedType v     case mIDType of       Just (IDType _ (Just CTArray{})) -> return ()                -- do nothing, it's already known to be an array-      _                                -> recordCType CTFunction (varName v) -- assume it's a function statement+      _                                ->+        -- inspect the subscript to make a safe(r) assumption about type+        -- (ideally, we would have more information coming in to this call)+        case v of+          ExpDataRef{} ->+            -- can't have a function in a struct: must be array but we can't+            -- record "some array", we need dimension info! so, refuse+            typeError "likely found an array in a struct, but unable to record type information" ss+          _ -> -- else assume it's a function statement+            recordCType CTFunction (varName v)  -- FIXME: if StFunctions can only be identified after types analysis -- is complete and disambiguation is performed, then how do we get

@@ -10,8 +10,6 @@ combinators are exposed to assist in manually configuring parsers. -} -{-# LANGUAGE ScopedTypeVariables #-}- module Language.Fortran.Parser   (   -- * Main parsers (ProgramFile, with transformation)@@ -24,7 +22,14 @@    -- * Other parsers   , f90Expr+  , byVerFromFilename +  -- ** Statement+  , byVerStmt+  , f66StmtNoTransform, f77StmtNoTransform, f77eStmtNoTransform+    , f77lStmtNoTransform, f90StmtNoTransform, f95StmtNoTransform+    , f2003StmtNoTransform+   -- * Various combinators   , transformAs, defaultTransformation   , Parser, ParseErrorSimple(..)@@ -141,8 +146,37 @@ f95NoTransform   = makeParserFree  F95.programParser   Fortran95 f2003NoTransform = makeParserFree  F2003.programParser Fortran2003 +f66StmtNoTransform, f77StmtNoTransform, f77eStmtNoTransform, f77lStmtNoTransform,+  f90StmtNoTransform, f95StmtNoTransform, f2003StmtNoTransform+    :: Parser (Statement A0)+f66StmtNoTransform   = makeParserFixed F66.statementParser   Fortran66+f77StmtNoTransform   = makeParserFixed F77.statementParser   Fortran77+f77eStmtNoTransform  = makeParserFixed F77.statementParser   Fortran77Extended+f77lStmtNoTransform  = makeParserFixed F77.statementParser   Fortran77Legacy+f90StmtNoTransform   = makeParserFree  F90.statementParser   Fortran90+f95StmtNoTransform   = makeParserFree  F95.statementParser   Fortran95+f2003StmtNoTransform = makeParserFree  F2003.statementParser Fortran2003++byVerStmt :: FortranVersion -> Parser (Statement A0)+byVerStmt = \case+  Fortran66         -> f66StmtNoTransform+  Fortran77         -> f77StmtNoTransform+  Fortran77Extended -> f77eStmtNoTransform+  Fortran77Legacy   -> f77lStmtNoTransform+  Fortran90         -> f90StmtNoTransform+  Fortran95         -> f95StmtNoTransform+  Fortran2003       -> f2003StmtNoTransform+  v                 -> error $  "Language.Fortran.Parser.byVerStmt: "+                             <> "no parser available for requested version: "+                             <> show v+ f90Expr :: Parser (Expression A0) f90Expr = makeParser initParseStateFreeExpr F90.expressionParser Fortran90++-- | Obtain a Fortran parser by assuming the version from the filename provided.+byVerFromFilename :: Parser (ProgramFile A0)+byVerFromFilename fn = byVer v fn+  where v = deduceFortranVersion fn  -------------------------------------------------------------------------------- 

@@ -530,6 +530,12 @@   ai <- getAlex   putAlex $ ai { aiCaseSensitive = False } +setInComment :: LexAction ()+setInComment = getAlex >>= \ai -> putAlex ai { aiInComment = True }++setNotInComment :: LexAction ()+setNotInComment = getAlex >>= \ai -> putAlex ai { aiInComment = False }+ enterFormat :: LexAction () enterFormat = do   ai <- getAlex@@ -590,20 +596,26 @@  -- Lex comments with whitespace included lexComment :: LexAction (Maybe Token)-lexComment =-  lexLineWithWhitespace $ \ m -> do+lexComment = do+  setCaseSensitive+  setInComment+  mt <- lexLineWithWhitespace $ \ m -> do     s <- getLexemeSpan     return . Just . TComment s $ tail m+  setCaseInsensitive+  setNotInComment+  pure mt  -- Get a line without losing the whitespace, then call continuation with it. lexLineWithWhitespace :: (String -> LexAction (Maybe Token)) -> LexAction (Maybe Token) lexLineWithWhitespace k = do+  incWhiteSensitiveCharCount   alex <- getAlex-  let modifiedAlex = alex { aiWhiteSensitiveCharCount = 1 }-  case alexGetByte modifiedAlex of-    Just (w, newAlex)-      | fromIntegral w /= ord '\n' -> putAlex newAlex >> lexLineWithWhitespace k+  mw <- case alexGetByte alex of+    Just (w, alex')+      | fromIntegral w /= ord '\n' -> putAlex alex' >> lexLineWithWhitespace k     _                              -> getMatch >>= k+  pure mw   --------------------------------------------------@@ -872,6 +884,7 @@   , aiPreviousToken             :: Maybe Token   , aiPreviousTokensInLine      :: [ Token ]   , aiCaseSensitive             :: Bool+  , aiInComment                 :: Bool   , aiInFormat                  :: Bool   , aiFortranVersion            :: FortranVersion   } deriving (Show)@@ -897,6 +910,7 @@   , aiPreviousToken = Nothing   , aiPreviousTokensInLine = [ ]   , aiCaseSensitive = False+  , aiInComment = False   , aiInFormat = False   , aiFortranVersion = fv   }@@ -935,10 +949,12 @@   -- If we are not parsing a Hollerith skip whitespace   | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai   -- Ignore inline comments-  | aiFortranVersion ai == Fortran77Legacy &&-    _isWhiteInsensitive && not _inFormat && _curChar == '!' = skip Comment ai+  | aiFortranVersion ai == Fortran77Legacy && _isWhiteInsensitive+    && not _inFormat && _curChar == '!' && not _blankLine+  = skip Comment ai   -- Ignore comments after column 72 in fortran77-  | aiFortranVersion ai == Fortran77Legacy && posColumn _position > 72 && _curChar /= '\n'+  | aiFortranVersion ai == Fortran77Legacy && not (aiInComment ai)+    && posColumn _position > 72 && _curChar /= '\n'   = skip Comment ai   -- Read genuine character and advance. Also covers white sensitivity.   | otherwise =@@ -962,6 +978,9 @@     _position = aiPosition ai     _isWhiteInsensitive = aiWhiteSensitiveCharCount ai == 0     _inFormat = aiInFormat ai+    _blankLine = case aiPreviousToken ai of+      Just (TNewline _) -> True+      _ -> False  alexInputPrevChar :: AlexInput -> Char alexInputPrevChar ai = aiPreviousChar ai@@ -1109,7 +1128,7 @@     AlexEOF -> return $ TEOF $ SrcSpan (getPos alexInput) (getPos alexInput)     AlexError _ -> do       parseState <- get-      fail $ psFilename parseState ++ ": lexing failed. "+      fail $ psFilename parseState ++ " - lexing failed: " ++ show (psAlexInput parseState)     AlexSkip newAlex _ -> putAlex newAlex >> lexer'     AlexToken newAlex _ action -> do       putAlex newAlex

@@ -1,7 +1,6 @@ {-| Parser/lexer monad, plus common functionality and definitions. -}  {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE CPP #-} 

@@ -0,0 +1,108 @@+{- |+Precise Fortran type & value model.++Due to Fortran syntax design and the fortran-src definitions handling multiple+evolutions of the language, the syntactic constructs in 'Language.Fortran.AST'+for Fortran types and values are clunky and awkward to use for modelling safe+operations. The representations in this sub-package enable performing efficient+operations with explicit, documented semantics (usually the de facto behaviour,+or adopted from gfortran).++The aims for this representation are _correctness_ and _efficiency_. All values+store enough information on the type level to recover their precise Fortran type+via inspection.+-}++module Language.Fortran.Repr+  (+  -- * Assorted notes+  -- ** Kind semantics+  -- $kind-semantics++  -- ** Exceptional behaviour+  -- $exceptional-behaviour++  -- ** Naming conventions+  -- $naming-conventions++  -- * Re-exports+  -- ** Fortran types+    module Language.Fortran.Repr.Type+  , module Language.Fortran.Repr.Type.Array+  , module Language.Fortran.Repr.Type.Scalar+  , module Language.Fortran.Repr.Type.Scalar.Common+  , module Language.Fortran.Repr.Type.Scalar.Int+  , module Language.Fortran.Repr.Type.Scalar.Real+  , module Language.Fortran.Repr.Type.Scalar.Complex+  , module Language.Fortran.Repr.Type.Scalar.String++  -- ** Fortran values+  , module Language.Fortran.Repr.Value+  , module Language.Fortran.Repr.Value.Array+  , module Language.Fortran.Repr.Value.Scalar+  , module Language.Fortran.Repr.Value.Scalar.Common+  , module Language.Fortran.Repr.Value.Scalar.Int+  , module Language.Fortran.Repr.Value.Scalar.Real+  , module Language.Fortran.Repr.Value.Scalar.Complex+  , module Language.Fortran.Repr.Value.Scalar.Logical+  , module Language.Fortran.Repr.Value.Scalar.String+  ) where++import Language.Fortran.Repr.Type+import Language.Fortran.Repr.Type.Array+import Language.Fortran.Repr.Type.Scalar+import Language.Fortran.Repr.Type.Scalar.Common+import Language.Fortran.Repr.Type.Scalar.Int+import Language.Fortran.Repr.Type.Scalar.Real+import Language.Fortran.Repr.Type.Scalar.Complex+import Language.Fortran.Repr.Type.Scalar.String++import Language.Fortran.Repr.Value+import Language.Fortran.Repr.Value.Array+import Language.Fortran.Repr.Value.Scalar+import Language.Fortran.Repr.Value.Scalar.Common+import Language.Fortran.Repr.Value.Scalar.Int+import Language.Fortran.Repr.Value.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Complex+import Language.Fortran.Repr.Value.Scalar.Logical+import Language.Fortran.Repr.Value.Scalar.String++{- $kind-semantics++Kinds in Fortran are natural number "tags" associated with certain intrinsic+types. They enable Fortran implementations to group similar types of value+together under the same Fortran type. That is, though an @INTEGER(4)@ and an+@INTEGER(8)@ are both integers, most Fortran compilers will use different+representations for the values. We match this in Haskell by defining a sum type+for a given Fortran type, and making a constructor for each valid kind.++Fortran standards do not specify full semantics for kinds, only things like+interactions and precision requirements. However, average modern Fortran+compilers tend to agree on certain things. So we follow gfortran's lead for+semantics. The following general rules exist:++  * The size in bytes of a stored value is equal to its type's kind value. For+    example, a @REAL(4)@ takes 4 bytes. In general, for any type, only powers of+    2 are ever valid kinds.+  * Different types have different permitted kind values. This is what prevents+    us from simply carrying around a type name and a kind. For example, in our+    representation (and most in use), @REAL(2)@ isn't a valid type, while+    @INTEGER(2)@ is.+-}++{- $exceptional-behaviour++Where possible, this representation also matches common exceptional behaviours+in Fortran expression evaluation - specifically using gfortran as a basis. For+example:++  * Integers overflow predictably.+  * Reals should have approximately matching behaviour, since both gfortran and+    Haskell use IEEE floats.+-}++{- $naming-conventions++To prevent clashes with common Haskell types and definitions, most+representation types are prefixed with @F@, read as _Fortran_.+-}

@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++{- | Compatibility definitions for working with term and type level natural+     numbers across multiple GHC versions.++Prior to GHC 9.2:++  * Term level natural numbers: @Natural :: Type@+  * Type level natural numbers: @n :: Nat@++As of GHC 9.2:++  * Term level natural numbers: @Natural :: Type@+  * Type level natural numbers: @n :: Natural@++To avoid issues, we export a 'NaturalK' kind that will refer to the correct+definition for your platform.+-}+module Language.Fortran.Repr.Compat.Natural ( Natural, NaturalK ) where++-- exports 'Natural' >= 9.2+import GHC.TypeNats++#if __GLASGOW_HASKELL__ >= 902+type NaturalK = Natural+#else+import Numeric.Natural+type NaturalK = Nat+#endif

@@ -0,0 +1,23 @@+module Language.Fortran.Repr.Eval.Common where++import qualified Language.Fortran.AST as F++{- | Monads which provide functionality to evaluate some Fortran type or value.++We abstract over the evaluation target type in order to reuse this for both+value evaluation, and "type evaluation", since there is (a small amount of)+overlap.++Instances of this class will have a way to access variables in the current+context (e.g. a @Reader@ over a @Map@), and log warnings (e.g. a @Writer+String@).+-}+class Monad m => MonadEval m where+    -- | Target type that we evaluate to.+    type EvalTo m+    lookupFVar :: F.Name -> m (Maybe (EvalTo m))++    -- | Arbitrarily record some user-facing information concerning evaluation.+    --+    -- For example, potentially useful when making defaulting decisions.+    warn :: String -> m ()

@@ -0,0 +1,16 @@+-- | Evaluate AST terms to types in the type representation.++module Language.Fortran.Repr.Eval.Type where++import qualified Language.Fortran.AST as F+import Language.Fortran.Repr.Type+import Language.Fortran.Repr.Eval.Common++fromExpression+    :: forall m a. (MonadEval m, EvalTo m ~ FType)+    => F.Expression a -> m (Either String FType)+fromExpression = \case+  F.ExpValue _ _ (F.ValVariable name) ->+    lookupFVar name >>= \case+      Nothing  -> return $ Left "no such variable found TODO"+      Just val -> return $ Right val

@@ -0,0 +1,415 @@+{-# LANGUAGE ConstraintKinds #-}++-- | Evaluate AST terms to values in the value representation.++module Language.Fortran.Repr.Eval.Value where++import qualified Language.Fortran.AST as F+import qualified Language.Fortran.AST.Literal.Real as F+import qualified Language.Fortran.AST.Literal.Complex as F+import qualified Language.Fortran.AST.Literal.Boz as F++import Language.Fortran.Repr.Value+import Language.Fortran.Repr.Value.Scalar+import Language.Fortran.Repr.Value.Scalar.Common+import Language.Fortran.Repr.Value.Scalar.Int.Machine+import Language.Fortran.Repr.Value.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Logical.Machine+import Language.Fortran.Repr.Value.Scalar.String++import Language.Fortran.Repr.Type ( FType )++import Language.Fortran.Repr.Eval.Common+import qualified Language.Fortran.Repr.Eval.Value.Op as Op++import GHC.Generics ( Generic )+import qualified Data.Text as Text+import qualified Data.Char+import qualified Data.Bits++import Control.Monad.Except++-- simple implementation+import Control.Monad.Reader+import Control.Monad.Writer+import qualified Data.Map as Map+import Data.Map ( Map )++-- | A convenience type over 'MonadEval' bringing all requirements into scope.+type MonadEvalValue m = (MonadEval m, EvalTo m ~ FValue, MonadError Error m)++-- | Value evaluation error.+data Error+  = ENoSuchVar F.Name+  | EKindLitBadType F.Name FType+  | ENoSuchKindForType String KindLit+  | EUnsupported String+  | EOp Op.Error+  | EOpTypeError String+  | ELazy String+  -- ^ Catch-all for non-grouped errors.+    deriving stock (Generic, Show, Eq)++-- TODO best for temp KPs: String, Integer, Text? Word8??+type KindLit = String++--------------------------------------------------------------------------------++-- | A simple pure interpreter for Fortran value evaluation programs.+type EvalValueSimple = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))++instance MonadEval EvalValueSimple where+    type EvalTo EvalValueSimple = FValue+    warn msg = tell [msg]+    lookupFVar nm = do+        m <- ask+        pure $ Map.lookup nm m++runEvalValueSimple+    :: Map F.Name FValue+    -> EvalValueSimple a -> Either Error (a, [String])+runEvalValueSimple m = flip runReader m . runExceptT . runWriterT++--------------------------------------------------------------------------------++evalVar :: MonadEvalValue m => F.Name -> m FValue+evalVar name =+    lookupFVar name >>= \case+      Nothing  -> err $ ENoSuchVar name+      Just val -> return val++evalExpr :: MonadEvalValue m => F.Expression a -> m FValue+evalExpr = \case+  F.ExpValue _ _ astVal ->+    case astVal of+      F.ValVariable name -> evalVar name+      -- TODO: Do same with ValIntrinsic??? idk...+      _ -> MkFScalarValue <$> evalLit astVal+  F.ExpUnary  _ _ uop e   -> do+    v <- evalExpr e+    evalUOp uop v+  F.ExpBinary _ _ bop le re -> do+    -- TODO 2022-08-23 raehik: here is where we would implement+    -- short-circuiting, by inspecting the bop earlier and having special cases+    -- for certain bops+    lv <- evalExpr le+    rv <- evalExpr re+    evalBOp bop lv rv+  F.ExpFunctionCall _ _ ve args -> do+    -- same here, could more arg evaluation into op+    evaledArgs <- traverse evalArg $ F.alistList args+    evalFunctionCall (forceVarExpr ve) evaledArgs+  _ -> err $ EUnsupported "Expression constructor"++forceVarExpr :: F.Expression a -> F.Name+forceVarExpr = \case+  F.ExpValue _ _ (F.ValVariable v) -> v+  F.ExpValue _ _ (F.ValIntrinsic v) -> v+  _ -> error "program error, sent me an expr that wasn't a name"++evalLit :: MonadEvalValue m => F.Value a -> m FScalarValue+evalLit = \case+  F.ValInteger i mkp -> do+    evalKp "4" mkp >>= \case+      "4" -> return $ FSVInt $ SomeFKinded $ FInt4 $ read i+      "8" -> return $ FSVInt $ SomeFKinded $ FInt8 $ read i+      "2" -> return $ FSVInt $ SomeFKinded $ FInt2 $ read i+      "1" -> return $ FSVInt $ SomeFKinded $ FInt1 $ read i+      k   -> err $ ENoSuchKindForType "INTEGER" k+  F.ValReal r mkp -> do+    evalRealKp (F.exponentLetter (F.realLitExponent r)) mkp >>= \case+      "4" -> return $ FSVReal $ SomeFKinded $ FReal4 $ F.readRealLit r+      "8" -> return $ FSVReal $ SomeFKinded $ FReal8 $ F.readRealLit r+      k   -> err $ ENoSuchKindForType "REAL" k+  F.ValLogical b mkp -> do+    evalKp "4" mkp >>= \case+      "4" -> return $ FSVLogical $ SomeFKinded $ FInt4 $ fLogicalNumericFromBool b+      "8" -> return $ FSVLogical $ SomeFKinded $ FInt8 $ fLogicalNumericFromBool b+      "2" -> return $ FSVLogical $ SomeFKinded $ FInt2 $ fLogicalNumericFromBool b+      "1" -> return $ FSVLogical $ SomeFKinded $ FInt1 $ fLogicalNumericFromBool b+      k   -> err $ ENoSuchKindForType "LOGICAL" k+  F.ValComplex (F.ComplexLit _ _ _cr _ci) ->+    -- TODO annoying & tedious. see Fortran 2008 spec 4.4.2.4+    -- 1. evaluate each part+    -- 2. determine kind parameter (largest real, or default if both ints)+    --    - fail here if a named part wasn't real or int+    -- 3. upgrade both parts to that kind+    -- 4. package and return+    err $ EUnsupported "COMPLEX literals"+  F.ValString s -> return $ FSVString $ someFString $ Text.pack s+  F.ValBoz boz -> do+    warn "requested to evaluate BOZ literal with no context: defaulting to INTEGER(4)"+    return $ FSVInt $ SomeFKinded $ FInt4 $ F.bozAsTwosComp boz+  F.ValHollerith s -> return $ FSVString $ someFString $ Text.pack s+  F.ValIntrinsic{} -> error "you tried to evaluate a lit, but it was an intrinsic name"+  F.ValVariable{} ->  error "you tried to evaluate a lit, but it was a variable name"+  F.ValOperator{} ->  error "you tried to evaluate a lit, but it was a custom operator name"+  F.ValAssignment ->  error "you tried to evaluate a lit, but it was an overloaded assignment name"+  F.ValStar       ->  error "you tried to evaluate a lit, but it was a star"+  F.ValColon      ->  error "you tried to evaluate a lit, but it was a colon"+  F.ValType{}     ->  error "not used anywhere, don't know what it is"++err :: MonadError Error m => Error -> m a+err = throwError++evalKp :: MonadEvalValue m => KindLit -> Maybe (F.KindParam a) -> m KindLit+evalKp kDef = \case+  Nothing -> return kDef+  Just kp -> case kp of+    F.KindParamInt _ _ k -> return k+    F.KindParamVar _ _ var ->+      lookupFVar var >>= \case+        Just val -> case val of+          MkFScalarValue (FSVInt (SomeFKinded i)) ->+            return $ fIntUOp' show show show show i+          _ -> err $ EKindLitBadType var (fValueType val)+        Nothing  -> err $ ENoSuchVar var++-- TODO needs cleanup: internal repetition, common parts with evalKp. also needs+-- a docstring+evalRealKp :: MonadEvalValue m => F.ExponentLetter -> Maybe (F.KindParam a) -> m KindLit+evalRealKp l mkp =+    kindViaKindParam >>= \case+      Nothing ->+        case l of+          F.ExpLetterE -> pure "4"+          F.ExpLetterD -> pure "8"+          F.ExpLetterQ -> do+            warn "TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"+            evalRealKp F.ExpLetterD mkp+      Just kkp ->+        case l of+          F.ExpLetterE -> -- @1.2E3_8@ syntax is permitted: use @_8@ kind param+            pure kkp+          F.ExpLetterD -> do -- @1.2D3_8@ syntax is nonsensical+            warn $  "TODO exponent letter wasn't E but you gave kind parameter."+                 <> "\nthis isn't allowed, but we'll default to"+                 <> " using kind parameter"+            pure kkp+          F.ExpLetterQ -> do+            warn "TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"+            evalRealKp F.ExpLetterD mkp+  where+    kindViaKindParam =+        case mkp of+          Nothing -> pure Nothing+          Just kp -> case kp of+            F.KindParamInt _ _ k -> pure $ Just k+            F.KindParamVar _ _ var ->+              lookupFVar var >>= \case+                Just val -> case val of+                  MkFScalarValue (FSVInt (SomeFKinded i)) ->+                    pure $ Just $ fIntUOp' show show show show i+                  _ -> err $ EKindLitBadType var (fValueType val)+                Nothing  -> err $ ENoSuchVar var++evalUOp :: MonadEvalValue m => F.UnaryOp -> FValue -> m FValue+evalUOp op v = do+    v' <- forceScalar v+    case op of+      F.Plus  -> wrapSOp $ Op.opIcNumericUOpInplace id     v'+      F.Minus -> wrapSOp $ Op.opIcNumericUOpInplace negate v'+      F.Not   -> -- TODO move this to Op (but logicals are a pain)+        case v' of+          FSVLogical (SomeFKinded bi) ->+            return $ MkFScalarValue $ FSVLogical $ SomeFKinded $ fLogicalNot bi+          _ -> err $ EOp $ Op.EBadArgType1 ["LOGICAL"] $ fScalarValueType v'+      _ -> err $ EUnsupported $ "operator: " <> show op++wrapOp :: MonadEvalValue m => Either Op.Error a -> m a+wrapOp = \case+  Right a -> return a+  Left  e -> err $ EOp e++-- | Wrap the output of an operation that returns a scalar value into the main+--   evaluator.+wrapSOp :: MonadEvalValue m => Either Op.Error FScalarValue -> m FValue+wrapSOp = \case+  Right a -> return $ MkFScalarValue a+  Left  e -> err $ EOp e++-- | Evaluate explicit binary operators (ones denoted as such in the AST).+--+-- Note that this does not cover all binary operators -- there are many+-- intrinsics which use function syntax, but are otherwise binary operators.+evalBOp :: MonadEvalValue m => F.BinaryOp -> FValue -> FValue -> m FValue+evalBOp bop l r = do+    -- TODO also see evalExpr: implement short-circuit eval here+    l' <- forceScalar l+    r' <- forceScalar r+    case bop of+      F.Addition       -> wrapSOp $ Op.opIcNumericBOp (+) l' r'+      F.Subtraction    -> wrapSOp $ Op.opIcNumericBOp (-) l' r'+      F.Multiplication -> wrapSOp $ Op.opIcNumericBOp (*) l' r'+++      -- TODO confirm correct operation (not checked much)+      F.Division -> wrapSOp $ Op.opIcNumericBOpRealIntSep (div) (/) l' r'++      F.Exponentiation -> -- TODO not looked, certainly custom+        err $ EUnsupported "exponentiation"++      F.Concatenation  ->+        case (l', r') of+          (FSVString ls, FSVString rs) ->+            return $ MkFScalarValue $ FSVString $ concatSomeFString ls rs+          _ -> err $ ELazy "concat strings only please"++      F.GT  -> defFLogical <$> wrapOp (Op.opIcNumRelBOp (>)  l' r')+      F.GTE -> defFLogical <$> wrapOp (Op.opIcNumRelBOp (>=) l' r')+      F.LT  -> defFLogical <$> wrapOp (Op.opIcNumRelBOp (<) l' r')+      F.LTE -> defFLogical <$> wrapOp (Op.opIcNumRelBOp (<=) l' r')+      F.NE  -> defFLogical <$> wrapOp (Op.opIcNumRelBOp (/=) l' r')+      F.EQ  -> defFLogical <$> wrapOp (Op.opEq l' r')++      F.And -> defFLogical <$> wrapOp (Op.opIcLogicalBOp (&&) l' r')+      F.Or  -> defFLogical <$> wrapOp (Op.opIcLogicalBOp (||) l' r')+      F.XOr -> defFLogical <$> wrapOp (Op.opIcLogicalBOp boolXor l' r')+      F.Equivalent -> defFLogical <$> wrapOp (Op.opIcLogicalBOp (==) l' r')+      F.NotEquivalent -> defFLogical <$> wrapOp (Op.opIcLogicalBOp (/=) l' r')++      F.BinCustom{} -> -- TODO+        err $ EUnsupported "custom binary operators"++boolXor :: Bool -> Bool -> Bool+boolXor True  False = True+boolXor False True  = True+boolXor _     _     = False++defFLogical :: Bool -> FValue+defFLogical =+    MkFScalarValue . FSVLogical . SomeFKinded . FInt4 . fLogicalNumericFromBool++evalFunctionCall :: MonadEvalValue m => F.Name -> [FValue] -> m FValue+evalFunctionCall fname args =+    case fname of++      "ior"  -> do+        args' <- forceArgs 2 args+        let [l, r] = args'+        l' <- forceScalar l+        r' <- forceScalar r+        evalIntrinsicIor l' r'++      "max"  -> evalIntrinsicMax args++      "char" -> do+        args' <- forceArgs 1 args+        let [v] = args'+        v' <- forceScalar v+        case v' of+          FSVInt (SomeFKinded i) -> do+            -- TODO better error handling+            let c    = Data.Char.chr (fIntUOp fromIntegral i)+            pure $ MkFScalarValue $ FSVString $ someFString $ Text.singleton c+          _ ->+            err $ EOpTypeError $+                "char: expected INT(x), got "<>show (fScalarValueType v')++      "not"  -> do+        args' <- forceArgs 1 args+        let [v] = args'+        v' <- forceScalar v+        case v' of+          FSVInt (SomeFKinded i) -> do+            pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ fIntUOpInplace Data.Bits.complement i+          _ ->+            err $ EOpTypeError $+                "not: expected INT(x), got "<>show (fScalarValueType v')++      "int"  -> do+        -- TODO a real pain. just implementing common bits for now+        -- TODO gfortran actually performs some range checks for constants!+        -- @int(128, 1)@ errors with "this INT(4) is too big for INT(1)".+        args' <- forceArgs 1 args+        let [v] = args'+        v' <- forceScalar v+        case v' of+          FSVInt{} ->+            pure $ MkFScalarValue v'+          FSVReal (SomeFKinded r) ->+            pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ FInt4 $ fRealUOp truncate r+          _ ->+            err $ EOpTypeError $+                "int: unsupported or unimplemented type: "<>show (fScalarValueType v')++      -- TODO all lies+      "int2" -> do+        args' <- forceArgs 1 args+        let [v] = args'+        v' <- forceScalar v+        case v' of+          FSVInt{} ->+            pure $ MkFScalarValue v'+          FSVReal (SomeFKinded r) ->+            pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ FInt2 $ fRealUOp truncate r+          _ ->+            err $ EOpTypeError $+                "int: unsupported or unimplemented type: "<>show (fScalarValueType v')++      _      -> err $ EUnsupported $ "function call: " <> fname++evalArg :: MonadEvalValue m => F.Argument a -> m FValue+evalArg (F.Argument _ _ _ ae) =+    case ae of+      F.ArgExpr        e -> evalExpr e+      F.ArgExprVar _ _ v -> evalVar  v++--------------------------------------------------------------------------------++forceScalar :: MonadEvalValue m => FValue -> m FScalarValue+forceScalar = \case+  MkFArrayValue{} -> err $ EUnsupported "no array values in eval for now thx"+  MkFScalarValue v' -> return v'++forceUnconsArg :: MonadEvalValue m => [a] -> m (a, [a])+forceUnconsArg = \case+  []   -> err $ EOpTypeError "not enough arguments"+  a:as -> return (a, as)++-- TODO can I use vector-sized to improve safety here? lol+-- it's just convenience either way+forceArgs :: MonadEvalValue m => Int -> [a] -> m [a]+forceArgs numArgs l =+    if   length l == numArgs+    then return l+    else err $ EOpTypeError $+            "expected "<>show numArgs<>" arguments; got "<>show (length l)++evalIntrinsicIor+    :: MonadEvalValue m => FScalarValue -> FScalarValue -> m FValue+evalIntrinsicIor l r = wrapSOp $ FSVInt <$> Op.opIor l r++-- https://gcc.gnu.org/onlinedocs/gfortran/MAX.html+-- TODO should support arrays! at least for >=F2010+evalIntrinsicMax+    :: MonadEvalValue m => [FValue] -> m FValue+evalIntrinsicMax = \case+  []   -> err $ EOpTypeError "max intrinsic expects at least 1 argument"+  v:vs -> do+    v' <- forceScalar v+    vs' <- traverse forceScalar vs+    go v' vs'+  where+    go vCurMax [] = pure $ MkFScalarValue vCurMax+    go vCurMax (v:vs) =+        case vCurMax of+          FSVInt{} ->+            case v of+              FSVInt{} -> do+                vNewMax <- wrapOp $ Op.opIcNumericBOp max vCurMax v+                go vNewMax vs+              _ ->+                err $ EOpTypeError $+                    "max: expected INT(x), got "<>show (fScalarValueType v)+          FSVReal{} ->+            case v of+              FSVReal{} -> do+                vNewMax <- wrapOp $ Op.opIcNumericBOp max vCurMax v+                go vNewMax vs+              _ ->+                err $ EOpTypeError $+                    "max: expected REAL(x), got "<>show (fScalarValueType v)+          _ ->+            err $ EOpTypeError $+                "max: unsupported type: "<> show (fScalarValueType vCurMax)

@@ -0,0 +1,144 @@+-- | Evaluate operations between values in the value representation.++module Language.Fortran.Repr.Eval.Value.Op where++import Language.Fortran.Repr.Eval.Value.Op.Some++import Language.Fortran.Repr.Value.Scalar.Machine+import Language.Fortran.Repr.Value.Scalar.Common+import Language.Fortran.Repr.Value.Scalar.Int.Machine+import Language.Fortran.Repr.Value.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Complex+import Language.Fortran.Repr.Value.Scalar.Logical.Machine+import Language.Fortran.Repr.Value.Scalar.String+import Language.Fortran.Repr.Type.Scalar+import Language.Fortran.Repr.Type.Scalar.Real+import GHC.Float ( float2Double )+import Data.Int++import Data.Bits++import Data.Singletons++-- | Operation TODO+data Error+  = EBadArgType1 [String] FScalarType+  | EBadArgType2 [String] FScalarType FScalarType+  | EGeneric String+    deriving stock (Show, Eq)++-- https://gcc.gnu.org/onlinedocs/gfortran/DBLE.html#DBLE+opIcDble :: FScalarValue -> Either Error (FReal 'FTReal8)+opIcDble = \case+  FSVComplex (SomeFKinded c) -> case c of+    FComplex8  r _i -> rfr8 $ float2Double r+    FComplex16 r _i -> rfr8 r+  FSVReal (SomeFKinded r) -> case r of+    FReal4 r'   -> rfr8 $ float2Double r'+    FReal8 _r'  -> Right r+  FSVInt (SomeFKinded i) -> rfr8 $ withFInt i+  v -> eBadArgType1 ["COMPLEX", "REAL", "INT"] v+  where rfr8 = Right . FReal8++eBadArgType1 :: [String] -> FScalarValue -> Either Error a+eBadArgType1 expected = Left . EBadArgType1 expected . fScalarValueType++eBadArgType2 :: [String] -> FScalarValue -> FScalarValue -> Either Error a+eBadArgType2 expected l r =+    Left $ EBadArgType2 expected (fScalarValueType l) (fScalarValueType r)++eGeneric :: String -> Either Error a+eGeneric = Left . EGeneric++opIcNumericBOp+    :: (forall a. (Num a, Ord a) => a -> a -> a)+    -> FScalarValue -> FScalarValue -> Either Error FScalarValue+opIcNumericBOp bop = go+  where+    go (FSVInt l) (FSVInt r) = Right $ FSVInt $ someFIntBOpWrap bop l r+    go (FSVInt (SomeFKinded l)) (FSVReal r) =+        Right $ FSVReal $ someFRealUOpWrap (\x -> withFInt l `bop` x) r+    -- TODO int complex+    go (FSVReal l) (FSVReal r) = Right $ FSVReal $ someFRealBOpWrap bop l r+    go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l)+    go (FSVReal l) (FSVComplex r) =+        Right $ FSVComplex $ someFComplexBOpWrap bop (someFComplexFromReal l) r++opIcNumericBOpRealIntSep+    :: (forall a. Integral  a => a -> a -> a)+    -> (forall a. RealFloat a => a -> a -> a)+    -> FScalarValue -> FScalarValue -> Either Error FScalarValue+opIcNumericBOpRealIntSep bopInt bopReal = go+  where+    go (FSVInt l) (FSVInt r) = Right $ FSVInt $ someFIntBOpWrap bopInt l r+    go (FSVInt (SomeFKinded l)) (FSVReal r) =+        Right $ FSVReal $ someFRealUOpWrap (\x -> withFInt l `bopReal` x) r+    -- TODO int complex+    go (FSVReal l) (FSVReal r) = Right $ FSVReal $ someFRealBOpWrap bopReal l r+    go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l)+    go (FSVReal l) (FSVComplex r) =+        Right $ FSVComplex $ someFComplexBOpWrap bopReal (someFComplexFromReal l) r++opIcNumRelBOp+    :: (forall a. Ord a => a -> a -> r)+    -> FScalarValue -> FScalarValue -> Either Error r+opIcNumRelBOp bop = go+  where+    go (FSVInt l) (FSVInt r) = Right $ someFIntBOp bop l r+    go (FSVInt (SomeFKinded l)) (FSVReal r) =+        Right $ someFRealUOp (\x -> withFInt l `bop` x) r+    -- TODO int complex+    go (FSVReal l) (FSVReal r) = Right $ someFRealBOp bop l r+    go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l)+    -- TODO real complex+    go (FSVString l) (FSVString r) = Right $ someFStringBOp bop l r++-- plus, minus+opIcNumericUOpInplace+    :: (forall a. Num a => a -> a)+    -> FScalarValue -> Either Error FScalarValue+opIcNumericUOpInplace uop = \case+  FSVInt  (SomeFKinded v) -> Right $ FSVInt  $ SomeFKinded $ fIntUOpInplace  uop v+  FSVReal (SomeFKinded v) -> Right $ FSVReal $ SomeFKinded $ fRealUOpInplace uop v+  v -> eBadArgType1 ["INT", "REAL"] v++-- and, or, eqv, neqv+opIcLogicalBOp+    :: (Bool -> Bool -> r)+    -> FScalarValue -> FScalarValue -> Either Error r+opIcLogicalBOp bop = go+  where+    go (FSVLogical (SomeFKinded l)) (FSVLogical (SomeFKinded r)) =+        Right $ bop (fLogicalToBool l) (fLogicalToBool r)+    go l r = eBadArgType2 ["LOGICAL"] l r++opEq :: FScalarValue -> FScalarValue -> Either Error Bool+opEq = go+  where+    go (FSVInt  l) (FSVInt  r) = Right $ someFIntBOp  (==) l r+    go (FSVReal l) (FSVReal r) = Right $ someFRealBOp (==) l r+    go (FSVInt (SomeFKinded l)) (FSVReal r) =+        Right $ someFRealUOp (\x -> withFInt l == x) r+    go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l)+    go (FSVString l) (FSVString r) = Right $ someFStringBOp (==) l r++-- | According to gfortran spec and F2010 spec, same kind required.+opIor' :: FInt k -> FInt k -> FInt k+opIor' = fIntBOpInplace (.|.)++opIor :: FScalarValue -> FScalarValue -> Either Error SomeFInt+opIor (FSVInt (SomeFKinded l)) (FSVInt (SomeFKinded r)) =+    case (l, r) of+      (FInt4{}, FInt4{}) -> do+        let out = opIor' l r+        pure $ SomeFKinded out+      (FInt8{}, FInt8{}) -> do+        let out = opIor' l r+        pure $ SomeFKinded out+      (FInt2{}, FInt2{}) -> do+        let out = opIor' l r+        pure $ SomeFKinded out+      (FInt1{}, FInt1{}) -> do+        let out = opIor' l r+        pure $ SomeFKinded out+opIor l r = eBadArgType2 ["INT", "INT"] l r

@@ -0,0 +1,177 @@+module Language.Fortran.Repr.Eval.Value.Op.Some where++import Language.Fortran.Repr.Value.Scalar.Common+import Language.Fortran.Repr.Value.Scalar.Int.Machine+import Language.Fortran.Repr.Value.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Complex++import Data.Int++someFIntUOpInplace'+    :: (Int8  -> Int8)+    -> (Int16 -> Int16)+    -> (Int32 -> Int32)+    -> (Int64 -> Int64)+    -> SomeFInt -> SomeFInt+someFIntUOpInplace' k1f k2f k4f k8f (SomeFKinded i) = SomeFKinded $+    fIntUOpInplace' k1f k2f k4f k8f i++someFIntUOp'+    :: (Int8  -> r)+    -> (Int16 -> r)+    -> (Int32 -> r)+    -> (Int64 -> r)+    -> SomeFInt -> r+someFIntUOp' k1f k2f k4f k8f (SomeFKinded i) =+    fIntUOp' k1f k2f k4f k8f i++someFIntUOp+    :: (forall a. IsFInt a => a -> r)+    -> SomeFInt -> r+someFIntUOp f = someFIntUOp' f f f f++someFIntUOpWrap'+    :: (Int8  -> Int8)+    -> (Int16 -> Int16)+    -> (Int32 -> Int32)+    -> (Int64 -> Int64)+    -> SomeFInt -> SomeFInt+someFIntUOpWrap' k1f  k2f  k4f  k8f  (SomeFKinded i) =+    fIntUOp'     k1f' k2f' k4f' k8f' i+  where+    k1f' = SomeFKinded . FInt1 . k1f+    k2f' = SomeFKinded . FInt2 . k2f+    k4f' = SomeFKinded . FInt4 . k4f+    k8f' = SomeFKinded . FInt8 . k8f++someFIntUOpWrap+    :: (forall a. IsFInt a => a -> a)+    -> SomeFInt -> SomeFInt+someFIntUOpWrap f = someFIntUOpWrap' f f f f++someFIntBOp'+    :: (Int8  -> Int8  -> r)+    -> (Int16 -> Int16 -> r)+    -> (Int32 -> Int32 -> r)+    -> (Int64 -> Int64 -> r)+    -> SomeFInt -> SomeFInt -> r+someFIntBOp' k1f k2f k4f k8f (SomeFKinded il) (SomeFKinded ir) =+    fIntBOp' k1f k2f k4f k8f il            ir++someFIntBOp+    :: (forall a. IsFInt a => a -> a -> r)+    -> SomeFInt -> SomeFInt -> r+someFIntBOp f = someFIntBOp' f f f f++someFIntBOpWrap'+    :: (Int8  -> Int8  -> Int8)+    -> (Int16 -> Int16 -> Int16)+    -> (Int32 -> Int32 -> Int32)+    -> (Int64 -> Int64 -> Int64)+    -> SomeFInt -> SomeFInt -> SomeFInt+someFIntBOpWrap' k1f  k2f  k4f  k8f =+    someFIntBOp' k1f' k2f' k4f' k8f'+  where+    k1f' l r = SomeFKinded $ FInt1 $ k1f l r+    k2f' l r = SomeFKinded $ FInt2 $ k2f l r+    k4f' l r = SomeFKinded $ FInt4 $ k4f l r+    k8f' l r = SomeFKinded $ FInt8 $ k8f l r++someFIntBOpWrap+    :: (forall a. IsFInt a => a -> a -> a)+    -> SomeFInt -> SomeFInt -> SomeFInt+someFIntBOpWrap f = someFIntBOpWrap' f f f f++--------------------------------------------------------------------------------++someFRealBOp'+    :: (Float  -> Float  -> r)+    -> (Double -> Double -> r)+    -> SomeFReal -> SomeFReal -> r+someFRealBOp' k4f k8f (SomeFKinded l) (SomeFKinded r) =+    fRealBOp' k4f k8f l             r++someFRealBOp+    :: (forall a. RealFloat a => a -> a -> r)+    -> SomeFReal -> SomeFReal -> r+someFRealBOp f = someFRealBOp' f f++someFRealBOpWrap'+    :: (Float  -> Float  -> Float)+    -> (Double -> Double -> Double)+    -> SomeFReal -> SomeFReal -> SomeFReal+someFRealBOpWrap' k4f  k8f =+    someFRealBOp' k4f' k8f'+  where+    k4f' l r = SomeFKinded $ FReal4 $ k4f l r+    k8f' l r = SomeFKinded $ FReal8 $ k8f l r++someFRealBOpWrap+    :: (forall a. RealFloat a => a -> a -> a)+    -> SomeFReal -> SomeFReal -> SomeFReal+someFRealBOpWrap f = someFRealBOpWrap' f f++someFRealUOp'+    :: (Float  -> r)+    -> (Double -> r)+    -> SomeFReal -> r+someFRealUOp' k4f k8f (SomeFKinded x) =+    fRealUOp' k4f k8f x++someFRealUOp+    :: (forall a. RealFloat a => a -> r)+    -> SomeFReal -> r+someFRealUOp f = someFRealUOp' f f++someFRealUOpWrap'+    :: (Float  -> Float)+    -> (Double -> Double)+    -> SomeFReal -> SomeFReal+someFRealUOpWrap' k4f  k8f =+    someFRealUOp' k4f' k8f'+  where+    k4f' = SomeFKinded . FReal4 . k4f+    k8f' = SomeFKinded . FReal8 . k8f++someFRealUOpWrap+    :: (forall a. RealFloat a => a -> a)+    -> SomeFReal -> SomeFReal+someFRealUOpWrap f = someFRealUOpWrap' f f++--------------------------------------------------------------------------------++someFComplexBOp'+    :: (Float  -> Float  -> a)+    -> (a -> a -> r)+    -> (Double -> Double -> b)+    -> (b -> b -> r)+    -> SomeFComplex -> SomeFComplex -> r+someFComplexBOp' k8f k8g k16f k16g (SomeFKinded l) (SomeFKinded r) =+    fComplexBOp' k8f k8g k16f k16g l                r++someFComplexBOp+    :: (forall a. RealFloat a => a -> a -> b)+    -> (b -> b -> r)+    -> SomeFComplex -> SomeFComplex -> r+someFComplexBOp f g = someFComplexBOp' f g f g++someFComplexBOpWrap'+    :: (Float  -> Float  -> Float)+    -> (Double -> Double -> Double)+    -> SomeFComplex -> SomeFComplex -> SomeFComplex+someFComplexBOpWrap' k8f     k16f =+    someFComplexBOp' k8f k8g k16f k16g+  where+    k8g  l r = SomeFKinded $ FComplex8  l r+    k16g l r = SomeFKinded $ FComplex16 l r++someFComplexBOpWrap+    :: (forall a. RealFloat a => a -> a -> a)+    -> SomeFComplex -> SomeFComplex -> SomeFComplex+someFComplexBOpWrap f = someFComplexBOpWrap' f f++someFComplexFromReal :: SomeFReal -> SomeFComplex+someFComplexFromReal (SomeFKinded r) =+    case r of+      FReal4 x -> SomeFKinded $ FComplex8  x 0.0+      FReal8 x -> SomeFKinded $ FComplex16 x 0.0

@@ -0,0 +1,46 @@+module Language.Fortran.Repr.Tmp where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as B+import Data.Word+import qualified Data.Text as Text+import Data.Text ( Text )+import qualified Data.Char as Char+import qualified Data.List as List++testF :: Float -> Text+testF = prettyHexByteString B.unpack . B.toLazyByteString . B.floatBE++testD :: Double -> Text+testD = prettyHexByteString B.unpack . B.toLazyByteString . B.doubleBE+++-- | Pretty print to default format @00 12 AB FF@: space between each byte, all+--   caps.+--+-- This format I consider most human readable. I prefer caps to draw attention+-- to this being data instead of text (you don't see that many capital letters+-- packed together in prose).+prettyHexByteString :: (a -> [Word8]) -> a -> Text+prettyHexByteString unpack =+      Text.concat+    . List.intersperse (Text.singleton ' ')+    . fmap (f . prettyHexByte Char.toUpper)+    . unpack+  where+    f :: (Char, Char) -> Text+    f (c1, c2) = Text.cons c1 $ Text.singleton c2++prettyHexByte :: (Char -> Char) -> Word8 -> (Char, Char)+prettyHexByte f w = (prettyNibble h, prettyNibble l)+  where+    (h,l) = fromIntegral w `divMod` 0x10+    prettyNibble = f . Char.intToDigit -- Char.intToDigit returns lower case++-- | Pretty print to "compact" format @0012abff@ (often output by hashers).+prettyHexByteStringCompact :: (a -> [Word8]) -> a -> Text+prettyHexByteStringCompact unpack =+    Text.concat . fmap (f . prettyHexByte id) . unpack+  where+    f :: (Char, Char) -> Text+    f (c1, c2) = Text.cons c1 $ Text.singleton c2

@@ -0,0 +1,10 @@+module Language.Fortran.Repr.Type where++import Language.Fortran.Repr.Type.Scalar+import Language.Fortran.Repr.Type.Array+import GHC.Generics ( Generic )+import Data.Data ( Data )++-- | A Fortran type (scalar or array).+data FType = MkFScalarType FScalarType | MkFArrayType FArrayType+    deriving stock (Generic, Eq, Show, Data)

@@ -0,0 +1,21 @@+module Language.Fortran.Repr.Type.Array where++import Language.Fortran.Repr.Type.Scalar+import Language.Fortran.Repr.Compat.Natural++import GHC.Generics ( Generic )+import Data.Data ( Data )++-- | A Fortran array type.+--+-- An array type is defined by a scalar type together with a shape.+data FArrayType = FArrayType+  { fatScalar :: FScalarType+  , fatShape  :: Shape+  } deriving stock (Generic, Data, Show, Eq, Ord)++newtype Shape = Shape { getShape :: [Natural] }+    deriving stock (Generic, Data, Show, Eq, Ord)++fatSize :: FArrayType -> Natural+fatSize = sum . getShape . fatShape

@@ -0,0 +1,34 @@+module Language.Fortran.Repr.Type.Scalar where++import Language.Fortran.Repr.Type.Scalar.Common+import Language.Fortran.Repr.Type.Scalar.Int+import Language.Fortran.Repr.Type.Scalar.Real+import Language.Fortran.Repr.Type.Scalar.Complex+import Language.Fortran.Repr.Type.Scalar.String++import Language.Fortran.Repr.Compat.Natural++import GHC.Generics ( Generic )+import Data.Data ( Data )++-- | A Fortran scalar type.+data FScalarType+  = FSTInt FTInt+  | FSTReal FTReal+  | FSTComplex FTReal+  | FSTLogical FTInt+  | FSTString Natural+  | FSTCustom String     -- ^ F77 structure, F90 DDT (non-intrinsic scalar)+    deriving stock (Generic, Data, Show, Eq, Ord)++prettyScalarType :: FScalarType -> String+prettyScalarType = \case+  FSTInt     k -> prettyKinded k "INTEGER"+  FSTReal    k -> prettyKinded k "REAL"+  FSTComplex k -> prettyKinded (FTComplexWrapper k) "COMPLEX"+  FSTLogical k -> prettyKinded k "LOGICAL"+  FSTString  l -> "CHARACTER("<>prettyCharLen l<>")"+  FSTCustom  t -> "TYPE("<>t<>")"++prettyKinded :: FKinded a => a -> String -> String+prettyKinded k name = name<>"("<>show (printFKind k)<>")"

@@ -0,0 +1,63 @@+module Language.Fortran.Repr.Type.Scalar.Common where++import Language.Fortran.Repr.Util+import Language.Fortran.Repr.Compat.Natural++import Data.Kind+import GHC.TypeNats++import Data.Type.Equality+import Data.Ord.Singletons+import Unsafe.Coerce++-- | Fortran kinds are represented by natural numbers. We use them on both type+--   and term levels.+type FKindTerm = Natural+type FKindType = NaturalK++-- | Reify a kind tag to its 'Natural' equivalent.+reifyKinded+    :: forall k (a :: k) n. (n ~ FKindOf a, KnownNat n)+    => Sing a -> FKindTerm+reifyKinded _ = natVal'' @n++-- | Fortran types which use simple integer kinds.+class FKinded (a :: Type) where+    type FKindOf (x :: a) :: FKindType+    type FKindDefault :: a++    -- | This we get via the type family, but require singletons.+    printFKind :: a -> FKindTerm++    -- | This we *should* get via the type family, but again require singletons.+    parseFKind :: FKindTerm -> Maybe a++{-+-- | Fortran strings+instance FKinded Natural where+    type FKindOf n = n+    type FKindDefault = 1 -- TODO ??+    printFKind = id+    parseFKind = Just+-}++--------------------------------------------------------------------------------++data SingCmp (l :: k) (r :: k)+  = SingEq (l :~: r)+  | SingLt+  | SingGt++-- | Upgrade an 'SOrdering' to include a proof of type equality for the equal+--   case.+--+-- We have no choice but to fake the 'Refl' with 'unsafeCoerce'. But assuming+-- 'SEQ' is used correctly, it should be safe.+singCompare+    :: forall k (a :: k) (b :: k). SOrd k+    => Sing a -> Sing b -> SingCmp a b+singCompare a b =+    case a `sCompare` b of+      SEQ -> SingEq (unsafeCoerce Refl)+      SLT -> SingLt+      SGT -> SingGt

@@ -0,0 +1,31 @@+{- | Fortran complex data type.++The complex data type is a simple layer on top of reals. We reuse the type and+value representation from reals, but for convenience, we provide a newtype+wrapper to enable writing a 'FKinded' instance for the complex type.++TODO candidate for improving. other ways of writing, name is long & poor.+alternatively, could enforce usage of this+-}++module Language.Fortran.Repr.Type.Scalar.Complex where++import Language.Fortran.Repr.Type.Scalar.Common+import Language.Fortran.Repr.Type.Scalar.Real++import GHC.Generics ( Generic )+import Data.Data ( Data )++newtype FTComplexWrapper = FTComplexWrapper { unFTComplexWrapper :: FTReal }+    deriving stock (Generic, Data, Show, Eq, Ord)++instance FKinded FTComplexWrapper where+    type FKindOf ('FTComplexWrapper 'FTReal4) = 8+    type FKindOf ('FTComplexWrapper 'FTReal8) = 16+    type FKindDefault = 'FTComplexWrapper 'FTReal4+    parseFKind = \case 8  -> Just $ FTComplexWrapper FTReal4+                       16 -> Just $ FTComplexWrapper FTReal8+                       _ -> Nothing+    printFKind = \case+      FTComplexWrapper FTReal4 -> 8+      FTComplexWrapper FTReal8 -> 16

@@ -0,0 +1,87 @@+{-# LANGUAGE TemplateHaskell, StandaloneKindSignatures, UndecidableInstances #-}+{-# LANGUAGE NoStarIsType #-}++module Language.Fortran.Repr.Type.Scalar.Int where++import Language.Fortran.Repr.Type.Scalar.Common++import GHC.Generics ( Generic )+import Data.Data ( Data )++import Data.Singletons.TH+-- required for deriving instances (seems like bug)+import Prelude.Singletons hiding ( type (-), type (*) )+import Data.Ord.Singletons++import GHC.TypeNats++$(singletons [d|+    -- | The Fortran integer type.+    data FTInt+      = FTInt1  -- ^ @INTEGER(1)@+      | FTInt2  -- ^ @INTEGER(2)@+      | FTInt4  -- ^ @INTEGER(4)@+      | FTInt8  -- ^ @INTEGER(8)@+      | FTInt16 -- ^ @INTEGER(16)@+        deriving stock (Eq, Ord, Show)+    |])+deriving stock instance Generic FTInt+deriving stock instance Data    FTInt+deriving stock instance Enum    FTInt++-- | Get the output type from combining two integer values of arbitrary kinds+--   (for example, adding an @INTEGER(1)@ and an @INTEGER(4)@).+--+-- TODO is this OK?? the @k k = k@ equation at top???+type FTIntCombine :: FTInt -> FTInt -> FTInt+type family FTIntCombine k1 k2 where+    FTIntCombine k k = k++    FTIntCombine 'FTInt16 _        = 'FTInt16+    FTIntCombine _        'FTInt16 = 'FTInt16+    FTIntCombine 'FTInt8  _        = 'FTInt8+    FTIntCombine _        'FTInt8  = 'FTInt8+    FTIntCombine 'FTInt4  _        = 'FTInt4+    FTIntCombine _        'FTInt4  = 'FTInt4+    FTIntCombine 'FTInt2  _        = 'FTInt2+    FTIntCombine _        'FTInt2  = 'FTInt2+    FTIntCombine 'FTInt1  'FTInt1  = 'FTInt1++instance FKinded FTInt where+    type FKindOf 'FTInt1  = 1+    type FKindOf 'FTInt2  = 2+    type FKindOf 'FTInt4  = 4+    type FKindOf 'FTInt8  = 8+    type FKindOf 'FTInt16 = 16+    type FKindDefault = 'FTInt4+    parseFKind = \case 1  -> Just FTInt1+                       2  -> Just FTInt2+                       4  -> Just FTInt4+                       8  -> Just FTInt8+                       16 -> Just FTInt16+                       _ -> Nothing+    -- spurious warning on GHC 9.0+    printFKind (FromSing x) = case x of+      SFTInt1  -> reifyKinded x+      SFTInt2  -> reifyKinded x+      SFTInt4  -> reifyKinded x+      SFTInt8  -> reifyKinded x+      SFTInt16 -> reifyKinded x++-- | @max k = 2^(8k-1) - 1@+type FTIntMax :: FTInt -> Nat+type family FTIntMax k where+    FTIntMax 'FTInt1  = 2^(8*1 -1) - 1+    FTIntMax 'FTInt2  = 2^(8*2 -1) - 1+    FTIntMax 'FTInt4  = 2^(8*4 -1) - 1+    FTIntMax 'FTInt8  = 2^(8*8 -1) - 1+    FTIntMax 'FTInt16 = 2^(8*16-1) - 1++-- | @min k = - (2^(8k-1))@ (make sure you negate when reifying etc!)+type FTIntMin :: FTInt -> Nat+type family FTIntMin k where+    FTIntMin 'FTInt1  = 2^(8*1 -1)+    FTIntMin 'FTInt2  = 2^(8*2 -1)+    FTIntMin 'FTInt4  = 2^(8*4 -1)+    FTIntMin 'FTInt8  = 2^(8*8 -1)+    FTIntMin 'FTInt16 = 2^(8*16-1)

@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell, StandaloneKindSignatures, UndecidableInstances #-}++module Language.Fortran.Repr.Type.Scalar.Real where++import Language.Fortran.Repr.Type.Scalar.Common++import GHC.Generics ( Generic )+import Data.Data ( Data )++import Data.Singletons.TH+-- required for deriving instances (seems like bug)+import Prelude.Singletons+import Data.Ord.Singletons++$(singletons [d|+    data FTReal+      = FTReal4+      | FTReal8+        deriving stock (Eq, Ord, Show)+    |])+deriving stock instance Generic FTReal+deriving stock instance Data    FTReal+deriving stock instance Enum    FTReal++-- | Get the output type from combining two real values of arbitrary kinds (for+--   example, adding a @REAL(4)@ and a @REAL(8)@).+type FTRealCombine :: FTReal -> FTReal -> FTReal+type family FTRealCombine k1 k2 where+    FTRealCombine 'FTReal8 _        = 'FTReal8+    FTRealCombine _        'FTReal8 = 'FTReal8+    FTRealCombine 'FTReal4 'FTReal4 = 'FTReal4++instance FKinded FTReal where+    type FKindOf 'FTReal4 = 4+    type FKindOf 'FTReal8 = 8+    type FKindDefault = 'FTReal4+    parseFKind = \case 4 -> Just FTReal4+                       8 -> Just FTReal8+                       _ -> Nothing+    -- spurious warning on GHC 9.0+    printFKind (FromSing x) = case x of+      SFTReal4 -> reifyKinded x+      SFTReal8 -> reifyKinded x

@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell, StandaloneKindSignatures, UndecidableInstances #-}++module Language.Fortran.Repr.Type.Scalar.String where++import Language.Fortran.Repr.Compat.Natural++import GHC.Generics ( Generic )+import Data.Data ( Data )++--import Data.Singletons.TH+-- required for deriving instances (seems like bug)+--import Prelude.Singletons+--import Data.Ord.Singletons++-- $(singletons [d|+-- | The length of a CHARACTER value.+--+-- IanH provides a great reference on StackOverflow:+-- https://stackoverflow.com/a/25051522/2246637+data CharLen+  = CharLen Natural+  -- ^ @CHARACTER(LEN=x)@ (where @x@ is a constant integer expression). Value+  --   has the given static length.++  | CharLenAssumed+  -- ^ @CHARACTER(LEN=*)@. F90. Value has assumed length. For a dummy argument,+  --   the length is assumed from the actual argument. For a PARAMETER named+  --   constant, the length is assumed from the length of the initializing+  --   expression.++  | CharLenDeferred+  -- ^ @CHARACTER(LEN=:)@. F2003. Value has deferred length. Must have the+  --   ALLOCATABLE or POINTER attribute.++    deriving stock (Eq, Ord, Show)+--    |])++deriving stock instance Generic CharLen+deriving stock instance Data    CharLen++prettyCharLen :: Natural -> String+prettyCharLen l = "LEN="<>show l

@@ -0,0 +1,11 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Language.Fortran.Repr.Util where++import Language.Fortran.Repr.Compat.Natural++import GHC.TypeNats+import GHC.Exts++natVal'' :: forall (a :: NaturalK). KnownNat a => Natural+natVal'' = natVal' (proxy# :: Proxy# a)

@@ -0,0 +1,25 @@+{- | Precise Fortran value model.++Note that we actually think about two different models: one storing values+"machine-like" (@Machine@), one storing them "mathematically idealized"+(@Idealized@). Only certain Fortran types have these split representations,+namely integers and logicals. The rest have a single representation each.++Both representations may be convenient in different own ways:++  * Machine representation is efficient, and should retain common overflow+    behaviours without explicitly handling them.+  * Idealized representation is easier to handle, and enables safe checking for+    overflows.++The same kind algebra is performed for both, so types & kinds should match.++As of 2022-08-15, idealized representation isn't properly supported -- this+module simply re-exports the machine representation.+-}++module Language.Fortran.Repr.Value+  ( module Language.Fortran.Repr.Value.Machine+  ) where++import Language.Fortran.Repr.Value.Machine

@@ -0,0 +1,5 @@+module Language.Fortran.Repr.Value.Array+  ( module Language.Fortran.Repr.Value.Array.Machine+  ) where++import Language.Fortran.Repr.Value.Array.Machine

@@ -0,0 +1,106 @@+{- | Fortran array representation primitives.++Fortran arrays are homogeneous: every element has the same type. That means a+@REAL(8)@ array must store only @REAL(8)@s, no @REAL(4)@s. We use some type+algebra to obtain correct-by-construction types.++Also, Fortran arrays are multi-dimensional. Rather than storing a single natural+number for a single dimension, or doing some recursive work for arrays of arrays+(which don't exist in Fortran), we instead store a list of naturals, defining+each dimension's extent.+-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++-- unwrapping somes gets you kind and length at the same time - I figure because+-- kind is just a convenience.++module Language.Fortran.Repr.Value.Array.Machine where++import Language.Fortran.Repr.Type.Array+import Language.Fortran.Repr.Type.Scalar+import Language.Fortran.Repr.Type.Scalar.Int+import Language.Fortran.Repr.Value.Scalar.Int.Machine+import Language.Fortran.Repr.Type.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Complex+import Language.Fortran.Repr.Value.Scalar.String+import Language.Fortran.Repr.Util ( natVal'' )++import GHC.TypeNats+import Language.Fortran.Repr.Compat.Natural++import qualified Data.Vector.Sized as V+import Data.Vector.Sized ( Vector )+import Data.Kind+import Data.Singletons++type Size :: [NaturalK] -> NaturalK+type family Size dims where+    Size (dim ': dims) = dim + Size dims+    Size '[]           = 0++-- can conveniently define kinded array types like so+data FVA (ft :: k -> Type) (fk :: k) (dims :: [NaturalK])+  = FVA { unFVA :: Vector (Size dims) (ft fk) }+deriving stock instance Show (ft fk) => Show (FVA ft fk dims)++-- makes rank 1 array+mkFVA1 :: forall l ft fk. Vector l (ft fk) -> FVA ft fk '[l]+mkFVA1 = FVA++-- reifies type info+fvaShape :: forall dims ft fk. KnownNats dims => FVA ft fk dims -> Shape+fvaShape _ = Shape $ natVals @dims++-- TODO+mkSomeFVA :: (forall l. KnownNat l => Vector l a -> r) -> [a] -> r+mkSomeFVA f as = V.withSizedList as f++-- | Reify a list of type-level 'Natural's.+class KnownNats (ns :: [NaturalK]) where natVals :: [Natural]+instance (KnownNat n, KnownNats ns) => KnownNats (n ': ns) where+    natVals = natVal'' @n : natVals @ns+instance KnownNats '[] where natVals = []++-- | Wrapper for defining an array of a kind-tagged Fortran type.+data SomeFVA k ft =+    forall (fk :: k) (dims :: [NaturalK]). (KnownNats dims, SingKind k, SingI fk)+        => SomeFVA { unSomeFVA :: FVA ft fk dims }+deriving stock instance Show (SomeFVA FTInt    FInt)+deriving stock instance Show (SomeFVA FTReal   FReal)+deriving stock instance Show (SomeFVA FTReal   FComplex)+deriving stock instance Show (SomeFVA NaturalK FString)++someFVAKind :: SomeFVA k ft -> Demote k+someFVAKind (SomeFVA (_ :: FVA ft fk dims)) = demote @fk++someFVAShape :: SomeFVA k ft -> Shape+someFVAShape (SomeFVA a) = fvaShape a++-- makes rank 1 array+mkSomeFVA1+    :: forall k ft (fk :: k). (SingKind k, SingI fk)+    => [ft fk] -> SomeFVA k ft+mkSomeFVA1 = mkSomeFVA $ SomeFVA . mkFVA1++data FArrayValue+  = FAVInt     (SomeFVA FTInt    FInt)+  | FAVReal    (SomeFVA FTReal   FReal)+  | FAVComplex (SomeFVA FTReal   FComplex)+  | FAVLogical (SomeFVA FTInt    FInt)+  | FAVString  (SomeFVA NaturalK FString)+deriving stock instance Show FArrayValue++fArrayValueType :: FArrayValue -> FArrayType+fArrayValueType = \case+  FAVInt     a -> go FSTInt     a+  FAVReal    a -> go FSTReal    a+  FAVComplex a -> go FSTComplex a+  FAVLogical a -> go FSTLogical a+  FAVString  a -> go FSTString  a+  where+    go :: (Demote k -> FScalarType) -> SomeFVA k ft -> FArrayType+    go f a = FArrayType (f (someFVAKind a)) (someFVAShape a)

@@ -0,0 +1,19 @@+module Language.Fortran.Repr.Value.Common where++data PrimRepr+  = Machine+  -- ^ Representation behaviour intends to match Fortran's. I guess we'll target+  --   gfortran.++  | Idealized+  -- ^ Use "mathematically ideal" representations e.g. 'Integer' for all+  --   @INTEGER(x)@ types. This enables us to check for correctness issues such+  --   as overflow.++data Check+  = Checked+  -- ^ Where relevant/possible, values will be checked for correctness (e.g.+  --   existence of over/underflow), and adjusted accordingly.++  | Unchecked+  -- ^ Values will not be checked for correctness.

@@ -0,0 +1,14 @@+module Language.Fortran.Repr.Value.Machine where++import Language.Fortran.Repr.Value.Scalar.Machine+import Language.Fortran.Repr.Value.Array.Machine+import Language.Fortran.Repr.Type++-- | A Fortran value (scalar or array).+data FValue = MkFArrayValue FArrayValue | MkFScalarValue FScalarValue+    deriving stock Show++fValueType :: FValue -> FType+fValueType = \case+  MkFScalarValue a -> MkFScalarType $ fScalarValueType a+  MkFArrayValue  a -> MkFArrayType  $ fArrayValueType  a

@@ -0,0 +1,18 @@+{- | Fortran scalar value representation.++For kinded Fortran types where different kinds use different representations,+e.g. INTEGER, the general pattern is to export a rank-2 function each for unary+and binary operations. They are restricted with a type class appropriate to the+underlying values stored e.g. 'Integral', 'RealFloat'. The function is then+specialized depending on the value's representation - and thus kind, since the+kind informs the representation.++For more details, see the 'Language.Fortran.Repr.Value.Scalar.Int.Machine'+module.+-}++module Language.Fortran.Repr.Value.Scalar+  ( module Language.Fortran.Repr.Value.Scalar.Machine+  ) where++import Language.Fortran.Repr.Value.Scalar.Machine

@@ -0,0 +1,20 @@+-- | Common definitions for Fortran scalar representations.+module Language.Fortran.Repr.Value.Scalar.Common where++import Data.Singletons++{- | Convenience wrapper which multiple Fortran tag-kinded intrinsic types fit.++A type @ft@ takes some type @fk@ of kind @k@, and we are permitted to move the+type between the term and type levels using the included singleton instances.++For example, integers are kinded with type level @FTInt@s. So we can define an+integer with an existential ("unknown") kind with the type @'SomeFKinded' FTInt+FInt@. By pattern matching on it, we recover the hidden kind tag (as well as+obtaining the value).+-}+data SomeFKinded k ft = forall (fk :: k). (SingKind k, SingI fk) => SomeFKinded (ft fk)++-- | Recover some @TYPE(x)@'s kind (the @x@).+someFKindedKind :: SomeFKinded k ft -> Demote k+someFKindedKind (SomeFKinded (_ :: ft fk)) = demote @fk

@@ -0,0 +1,47 @@+{- | Fortran COMPLEX value representation.++A Fortran COMPLEX is simply two REALs of the same kind.+-}++module Language.Fortran.Repr.Value.Scalar.Complex where++import Language.Fortran.Repr.Value.Scalar.Common+import Language.Fortran.Repr.Type.Scalar.Real+import GHC.Float ( float2Double )++data FComplex (k :: FTReal) where+    FComplex8  :: Float  -> Float  -> FComplex 'FTReal4+    FComplex16 :: Double -> Double -> FComplex 'FTReal8+deriving stock instance Show (FComplex k)+deriving stock instance Eq   (FComplex k)+deriving stock instance Ord  (FComplex k) -- TODO++type SomeFComplex = SomeFKinded FTReal FComplex+deriving stock instance Show SomeFComplex+instance Eq SomeFComplex where+    (SomeFKinded l) == (SomeFKinded r) = fComplexBOp (==) (&&) l r++fComplexBOp'+    :: (Float  -> Float  -> a)+    -> (a -> a -> r)+    -> (Double -> Double -> b)+    -> (b -> b -> r)+    -> FComplex kl -> FComplex kr -> r+fComplexBOp' k8f k8g k16f k16g l r =+    case (l, r) of+      (FComplex8  lr li, FComplex8  rr ri) -> k8g  (k8f  lr rr) (k8f  li ri)+      (FComplex16 lr li, FComplex16 rr ri) -> k16g (k16f lr rr) (k16f li ri)+      (FComplex8  lr li, FComplex16 rr ri) ->+        let lr' = float2Double lr+            li' = float2Double li+        in  k16g (k16f lr' rr) (k16f li' ri)+      (FComplex16 lr li, FComplex8  rr ri) ->+        let rr' = float2Double rr+            ri' = float2Double ri+        in  k16g (k16f lr rr') (k16f li ri')++fComplexBOp+    :: (forall a. RealFloat a => a -> a -> b)+    -> (b -> b -> r)+    -> FComplex kl -> FComplex kr -> r+fComplexBOp f g = fComplexBOp' f g f g

@@ -0,0 +1,5 @@+module Language.Fortran.Repr.Value.Scalar.Int+  ( module Language.Fortran.Repr.Value.Scalar.Int.Machine+  ) where++import Language.Fortran.Repr.Value.Scalar.Int.Machine

@@ -0,0 +1,88 @@+{- | Idealized Fortran INTEGER values.++This module stores Fortran INTEGER values in a Haskell 'Integer', together with+a phantom type describing the Fortran kind. This way, we can safely check for+bounds issues, and leave exact behaviour up to the user.+-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilyDependencies #-} -- just for better inference (maybe)+{-# LANGUAGE DerivingVia #-}++module Language.Fortran.Repr.Value.Scalar.Int.Idealized where++import Language.Fortran.Repr.Type.Scalar.Int+import Language.Fortran.Repr.Value.Scalar.Common+import Data.Kind+import Data.Int+import Data.Singletons++type FIntMRep :: FTInt -> Type+type family FIntMRep k = r | r -> k where+    FIntMRep 'FTInt1 = Int8+    FIntMRep 'FTInt2 = Int16+    FIntMRep 'FTInt4 = Int32+    FIntMRep 'FTInt8 = Int64++newtype FIntI (k :: FTInt) = FIntI Integer+    deriving (Show, Eq, Ord) via Integer++fIntICheckBounds+    :: forall k rep. (rep ~ FIntMRep k, Bounded rep, Integral rep)+    => FIntI k -> Maybe String+fIntICheckBounds (FIntI i) =+    if   i > fromIntegral (maxBound @rep)+    then Just "TODO too large"+    else if 　i < fromIntegral (minBound @rep)+         then Just "TODO too small"+         else Nothing++type SomeFIntI = SomeFKinded FTInt FIntI+deriving stock instance Show SomeFIntI+instance Eq SomeFIntI where+    (SomeFKinded (FIntI l)) == (SomeFKinded (FIntI r)) = l == r++-- this might look silly, but it's because even if we don't do kinded+-- calculations, we must still kind the output+someFIntIBOpWrap+    :: (Integer -> Integer -> Integer)+    -> SomeFIntI -> SomeFIntI -> SomeFIntI+someFIntIBOpWrap f l@(SomeFKinded (FIntI il)) r@(SomeFKinded (FIntI ir)) =+    case (someFKindedKind l, someFKindedKind r) of+      (FTInt16, _) -> as @'FTInt16+      (_, FTInt16) -> as @'FTInt16+      (FTInt8, _) -> as @'FTInt8+      (_, FTInt8) -> as @'FTInt8+      (FTInt4, _) -> as @'FTInt4+      (_, FTInt4) -> as @'FTInt4+      (FTInt2, _) -> as @'FTInt2+      (_, FTInt2) -> as @'FTInt2+      (FTInt1, FTInt1) -> as @'FTInt1+  where+    x = f il ir+    as :: forall (k :: FTInt). SingI k => SomeFIntI+    as = SomeFKinded $ FIntI @k x++{-+fIntIBOpWrap+    :: forall kl kr. (Integer -> Integer -> Integer)+    -> FIntI kl -> FIntI kr -> FIntI (FTIntCombine kl kr)+fIntIBOpWrap f l r =+    case (l, r) of+      (FIntI il :: FIntI 'FTInt16, FIntI ir) -> FIntI @'FTInt16 $ f il ir++    {-+      (FIntI l) (FIntI r) =+    case (demote @kl, demote @kr) of+      (FTInt16, _) -> FIntI @'FTInt16 x+      (_, FTInt16) -> FIntI @'FTInt16 x+      (FTInt8, _)  -> FIntI @'FTInt8 x+      (_, FTInt8)  -> FIntI @'FTInt8 x+      (FTInt4, _)  -> FIntI @'FTInt4 x+      (_, FTInt4)  -> FIntI @'FTInt4 x+      (FTInt2, _)  -> FIntI @'FTInt2 x+      (_, FTInt2)  -> FIntI @'FTInt2 x+      (FTInt1, FTInt1) -> FIntI @'FTInt1 x+      -}+-}

@@ -0,0 +1,215 @@+{- | Machine Fortran INTEGER values.++This module stores Fortran INTEGER values in a matching Haskell machine integer+type. For example, an @INT(4)@ would be stored in an 'Int32'. This way, we get+both efficient operations and common overflow behaviour (which hopefully matches+most Fortran compilers), and explicitly encode kinding semantics via promoting+integral types.+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Language.Fortran.Repr.Value.Scalar.Int.Machine+  ( FInt(..)+  , SomeFInt+  , type IsFInt++  , fIntUOp+  , fIntUOp'+  , fIntUOpInplace+  , fIntUOpInplace'+  , fIntUOpInternal++  , fIntBOp+  , fIntBOp'+  , fIntBOpInplace+  , fIntBOpInplace'+  , fIntBOpInternal++  , withFInt+  ) where++import Language.Fortran.Repr.Type.Scalar.Int+import Language.Fortran.Repr.Value.Scalar.Common+import Data.Int+import Data.Functor.Const++import Data.Bits ( Bits )++import Language.Fortran.Repr.Util ( natVal'' )+import GHC.TypeNats++-- | A Fortran integer value, tagged with its kind.+data FInt (k :: FTInt) where+    FInt1 :: Int8  -> FInt 'FTInt1 -- ^ @INTEGER(1)@+    FInt2 :: Int16 -> FInt 'FTInt2 -- ^ @INTEGER(2)@+    FInt4 :: Int32 -> FInt 'FTInt4 -- ^ @INTEGER(4)@+    FInt8 :: Int64 -> FInt 'FTInt8 -- ^ @INTEGER(8)@+deriving stock instance Show (FInt k)+deriving stock instance Eq   (FInt k)+deriving stock instance Ord  (FInt k)++type IsFInt a = (Integral a, Bits a)++type SomeFInt = SomeFKinded FTInt FInt+deriving stock instance Show SomeFInt+instance Eq SomeFInt where+    (SomeFKinded l) == (SomeFKinded r) = fIntBOp (==) l r++-- | Low-level 'FInt' unary operator. Runs an operation over some 'FInt', and+--   stores it kinded. The user gets to choose how the kind is used: it can be+--   used to wrap the result back into an 'FInt', or ignored using 'Const'.+--+-- Pattern matches are ordered to match more common ops earlier.+fIntUOpInternal+    :: (Int8  -> ft 'FTInt1)+    -> (Int16 -> ft 'FTInt2)+    -> (Int32 -> ft 'FTInt4)+    -> (Int64 -> ft 'FTInt8)+    -> FInt k -> ft k+fIntUOpInternal k1f k2f k4f k8f = \case+  FInt4 i32 -> k4f i32+  FInt8 i64 -> k8f i64+  FInt2 i16 -> k2f i16+  FInt1 i8  -> k1f i8++-- | Run an operation over some 'FInt', with a concrete function for each kind.+fIntUOp'+    :: (Int8  -> r)+    -> (Int16 -> r)+    -> (Int32 -> r)+    -> (Int64 -> r)+    -> FInt k -> r+fIntUOp' k1f k2f k4f k8f =+      getConst+    . fIntUOpInternal (Const . k1f) (Const . k2f) (Const . k4f) (Const . k8f)++-- | Run an operation over some 'FInt'.+fIntUOp+    :: forall r k+    .  (forall a. IsFInt a => a -> r)+    -> FInt k -> r+fIntUOp f = fIntUOp' f f f f++-- | Run an inplace operation over some 'FInt', with a concrete function for+--   each kind.+fIntUOpInplace'+    :: (Int8  -> Int8)+    -> (Int16 -> Int16)+    -> (Int32 -> Int32)+    -> (Int64 -> Int64)+    -> FInt k -> FInt k+fIntUOpInplace' k1f k2f k4f k8f =+    fIntUOpInternal (FInt1 . k1f) (FInt2 . k2f) (FInt4 . k4f) (FInt8 . k8f)++-- | Run an inplace operation over some 'FInt'.+fIntUOpInplace+    :: (forall a. IsFInt a => a -> a)+    -> FInt k -> FInt k+fIntUOpInplace f = fIntUOpInplace' f f f f++-- | Low-level 'FInt' binary operator. Combine two 'FInt's, coercing different+--   kinds, and store the result kinded.+--+-- Pattern matches are ordered to match more common ops earlier.+fIntBOpInternal+    :: (Int8  -> Int8  -> ft 'FTInt1)+    -> (Int16 -> Int16 -> ft 'FTInt2)+    -> (Int32 -> Int32 -> ft 'FTInt4)+    -> (Int64 -> Int64 -> ft 'FTInt8)+    -> FInt kl -> FInt kr -> ft (FTIntCombine kl kr)+fIntBOpInternal k1f k2f k4f k8f il ir = case (il, ir) of+  (FInt4 l32, FInt4 r32) -> k4f l32 r32+  (FInt8 l64, FInt8 r64) -> k8f l64 r64++  (FInt4 l32, FInt8 r64) -> k8f (fromIntegral l32) r64+  (FInt8 l64, FInt4 r32) -> k8f l64 (fromIntegral r32)++  (FInt4 l32, FInt2 r16) -> k4f l32 (fromIntegral r16)+  (FInt2 l16, FInt4 r32) -> k4f (fromIntegral l16) r32++  (FInt4 l32, FInt1 r8)  -> k4f l32 (fromIntegral r8)+  (FInt1 l8,  FInt4 r32) -> k4f (fromIntegral l8) r32++  (FInt8 l64, FInt2 r16) -> k8f l64 (fromIntegral r16)+  (FInt2 l16, FInt8 r64) -> k8f (fromIntegral l16) r64++  (FInt8 l64, FInt1 r8)  -> k8f l64 (fromIntegral r8)+  (FInt1 l8,  FInt8 r64) -> k8f (fromIntegral l8) r64++  (FInt2 l16, FInt2 r16) -> k2f l16 r16+  (FInt2 l16, FInt1 r8)  -> k2f l16 (fromIntegral r8)+  (FInt1 l8,  FInt2 r16) -> k2f (fromIntegral l8) r16++  (FInt1 l8,  FInt1 r8)  -> k1f l8 r8++fIntBOp'+    :: (Int8  -> Int8  -> r)+    -> (Int16 -> Int16 -> r)+    -> (Int32 -> Int32 -> r)+    -> (Int64 -> Int64 -> r)+    -> FInt kl -> FInt kr -> r+fIntBOp' k1f k2f k4f k8f il ir =+      getConst+    $ fIntBOpInternal (go k1f) (go k2f) (go k4f) (go k8f) il ir+  where go g l r = Const $ g l r++fIntBOp+    :: (forall a. IsFInt a => a -> a -> r)+    -> FInt kl -> FInt kr -> r+fIntBOp f = fIntBOp' f f f f++fIntBOpInplace'+    :: (Int8  -> Int8  -> Int8)+    -> (Int16 -> Int16 -> Int16)+    -> (Int32 -> Int32 -> Int32)+    -> (Int64 -> Int64 -> Int64)+    -> FInt kl -> FInt kr -> FInt (FTIntCombine kl kr)+fIntBOpInplace' k1f k2f k4f k8f =+    fIntBOpInternal (go FInt1 k1f) (go FInt2 k2f) (go FInt4 k4f) (go FInt8 k8f)+  where go f g l r = f $ g l r++fIntBOpInplace+    :: (forall a. IsFInt a => a -> a -> a)+    -> FInt kl -> FInt kr -> FInt (FTIntCombine kl kr)+fIntBOpInplace f = fIntBOpInplace' f f f f++-- | Treat any 'FInt' as a 'Num'.+--+-- TODO remove. means being explicit with coercions to real in eval.+withFInt :: Num a => FInt k -> a+withFInt = fIntUOp fromIntegral++fIntMax :: forall (k :: FTInt). KnownNat (FTIntMax k) => Int64+fIntMax = fromIntegral $ natVal'' @(FTIntMax k)++fIntMin :: forall (k :: FTInt). KnownNat (FTIntMin k) => Int64+fIntMin = fromIntegral $ natVal'' @(FTIntMin k)++-- TODO improve (always return answer, and a flag indicating if there was an+-- error)+fIntCoerceChecked+    :: forall kout kin+    .  (KnownNat (FTIntMax kout), KnownNat (FTIntMin kout))+    => SFTInt kout -> FInt kin -> Either String (FInt kout)+fIntCoerceChecked ty = fIntUOp $ \n ->+    if fromIntegral n > fIntMax @kout then+        Left "too large for new size"+    else if fromIntegral n < fIntMin @kout then+        Left "too small for new size"+    else+        case ty of+          SFTInt1  -> Right $ FInt1 $ fromIntegral n+          SFTInt2  -> Right $ FInt2 $ fromIntegral n+          SFTInt4  -> Right $ FInt4 $ fromIntegral n+          SFTInt8  -> Right $ FInt8 $ fromIntegral n+          SFTInt16 -> Left "can't represent INTEGER(16) yet, sorry"++-- can also define this (and stronger funcs) with singletons+fIntType :: FInt (k :: FTInt) -> FTInt+fIntType = \case+  FInt1{} -> FTInt1+  FInt2{} -> FTInt2+  FInt4{} -> FTInt4+  FInt8{} -> FTInt8

@@ -0,0 +1,5 @@+module Language.Fortran.Repr.Value.Scalar.Logical+  ( module Language.Fortran.Repr.Value.Scalar.Logical.Machine+  ) where++import Language.Fortran.Repr.Value.Scalar.Logical.Machine

@@ -0,0 +1,13 @@+{- | Idealized Fortran LOGICAL values.++In cases where you don't need the machine representation of a @LOGICAL(x)@,+which is likely to be an @INTEGER(x)@, you can store all kinds with a Haskell+'Bool'.+-}++module Language.Fortran.Repr.Value.Scalar.Logical.Idealized where++import Language.Fortran.Repr.Type.Scalar.Int++newtype FLogical (k :: FTInt) = FLogical Bool+    deriving stock (Show, Eq, Ord)

@@ -0,0 +1,27 @@+{- | Machine Fortran LOGICAL values.++Fortran compilers usually store LOGICALs as INTEGERs (they former is tied to the+latter in the specifications). To more accurately simulate their behaviour, we+represent them directly as integers, and simply provide a handful of definitions+for using them as booleans.+-}++module Language.Fortran.Repr.Value.Scalar.Logical.Machine where++import Language.Fortran.Repr.Value.Scalar.Int.Machine++-- | Retrieve the boolean value stored by a @LOGICAL(x)@.+fLogicalToBool :: FInt k -> Bool+fLogicalToBool = fIntUOp $ consumeFLogicalNumeric True False++-- | Convert a bool to its Fortran machine representation in any numeric type.+fLogicalNumericFromBool :: Num a => Bool -> a+fLogicalNumericFromBool = \case True -> 1; False -> 0++-- | Consume some Fortran logical stored using an integer.+consumeFLogicalNumeric :: (Num a, Eq a) => r -> r -> a -> r+consumeFLogicalNumeric whenTrue whenFalse bi =+    if bi == 1 then whenTrue else whenFalse++fLogicalNot :: FInt k -> FInt k+fLogicalNot = fIntUOpInplace (consumeFLogicalNumeric 0 1)

@@ -0,0 +1,50 @@+module Language.Fortran.Repr.Value.Scalar.Machine+  (+  -- * Note on type coercion implementation+  -- $type-coercion-implementation++    FScalarValue(..)+  , fScalarValueType+  ) where++import Language.Fortran.Repr.Value.Scalar.Common+import Language.Fortran.Repr.Value.Scalar.Int.Machine+import Language.Fortran.Repr.Value.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Complex+import Language.Fortran.Repr.Value.Scalar.String+import Language.Fortran.Repr.Type.Scalar+import GHC.Generics ( Generic )++{- $type-coercion-implementation++When you run a binary operation on two Fortran values, type coercion may take+place depending on the types of the values. This complicates evaluation code,+because now we have to export two sets of functions for operating on values: one+for returning a kinded value (e.g. addition returns the same type), and one for+non-kinded values (e.g. equality returns a boolean).++On the lowest level, e.g. for operating over @INTEGER(x)@ and @INTEGER(y)@, we+resolve this by doing the coercion in an internal function which is polymorphic+over the result type, and using that in both sets of functions. To operate+kinded, we use the relevant type. To operate unkinded, we use+@'Data.Functor.Const' r@, which ignores the kind and just stores a value of type+'r'.+-}++-- | A Fortran scalar value.+data FScalarValue+  = FSVInt     SomeFInt+  | FSVReal    SomeFReal+  | FSVComplex SomeFComplex+  | FSVLogical SomeFInt+  | FSVString  SomeFString+    deriving stock (Generic, Show, Eq)++-- | Recover a Fortran scalar value's type.+fScalarValueType :: FScalarValue -> FScalarType+fScalarValueType = \case+  FSVInt     a -> FSTInt     $ someFKindedKind a+  FSVReal    a -> FSTReal    $ someFKindedKind a+  FSVComplex a -> FSTComplex $ someFKindedKind a+  FSVLogical a -> FSTLogical $ someFKindedKind a+  FSVString  a -> FSTString  $ someFStringLen  a

@@ -0,0 +1,106 @@+module Language.Fortran.Repr.Value.Scalar.Real+  ( FReal(..)+  , SomeFReal++  , fRealUOp+  , fRealUOp'+  , fRealUOpInplace+  , fRealUOpInplace'+  , fRealUOpInternal++  , fRealBOp+  , fRealBOp'+  , fRealBOpInplace+  , fRealBOpInplace'+  , fRealBOpInternal+  ) where++import Language.Fortran.Repr.Type.Scalar.Real+import Language.Fortran.Repr.Value.Scalar.Common+import GHC.Float ( float2Double )+import Data.Functor.Const++data FReal (k :: FTReal) where+    FReal4 :: Float  -> FReal 'FTReal4+    FReal8 :: Double -> FReal 'FTReal8+deriving stock instance Show (FReal k)+deriving stock instance Eq   (FReal k)+deriving stock instance Ord  (FReal k)++fRealUOpInternal+    :: (Float  -> ft 'FTReal4)+    -> (Double -> ft 'FTReal8)+    -> FReal k -> ft k+fRealUOpInternal k4f k8f = \case+  FReal4 fl -> k4f fl+  FReal8 db -> k8f db++-- | Run an operation over some 'FReal', with a concrete function for each kind.+fRealUOp'+    :: (Float  -> r)+    -> (Double -> r)+    -> FReal k -> r+fRealUOp' k4f k8f = getConst . fRealUOpInternal (Const . k4f) (Const . k8f)++-- | Run an operation over some 'FReal'.+fRealUOp+    :: (forall a. RealFloat a => a -> r)+    -> FReal k -> r+fRealUOp f = fRealUOp' f f++-- | Run an inplace operation over some 'FReal', with a concrete function for+--   each kind.+fRealUOpInplace'+    :: (Float  -> Float)+    -> (Double -> Double)+    -> FReal k -> FReal k+fRealUOpInplace' k4f k8f = fRealUOpInternal (FReal4 . k4f) (FReal8. k8f)++-- | Run an inplace operation over some 'FReal'.+fRealUOpInplace+    :: (forall a. RealFloat a => a -> a)+    -> FReal k -> FReal k+fRealUOpInplace f = fRealUOpInplace' f f++-- | Combine two Fortran reals with a binary operation, coercing different+--   kinds.+fRealBOpInternal+    :: (Float  -> Float  -> ft 'FTReal4)+    -> (Double -> Double -> ft 'FTReal8)+    -> FReal kl -> FReal kr -> ft (FTRealCombine kl kr)+fRealBOpInternal k4f k8f l r = case (l, r) of+  (FReal4 lr, FReal4 rr) -> k4f lr rr+  (FReal8 lr, FReal8 rr) -> k8f lr rr+  (FReal4 lr, FReal8 rr) -> k8f (float2Double lr) rr+  (FReal8 lr, FReal4 rr) -> k8f lr (float2Double rr)++fRealBOp'+    :: (Float  -> Float  -> r)+    -> (Double -> Double -> r)+    -> FReal kl -> FReal kr -> r+fRealBOp' k4f k8f l r = getConst $ fRealBOpInternal (go k4f) (go k8f) l r+  where go g l' r' = Const $ g l' r'++fRealBOp+    :: (forall a. RealFloat a => a -> a -> r)+    -> FReal kl -> FReal kr -> r+fRealBOp f = fRealBOp' f f++fRealBOpInplace'+    :: (Float  -> Float  -> Float)+    -> (Double -> Double -> Double)+    -> FReal kl -> FReal kr -> FReal (FTRealCombine kl kr)+fRealBOpInplace' k4f k8f = fRealBOpInternal (go FReal4 k4f) (go FReal8 k8f)+  where go f g l r = f $ g l r++fRealBOpInplace+    :: (forall a. RealFloat a => a -> a -> a)+    -> FReal kl -> FReal kr -> FReal (FTRealCombine kl kr)+fRealBOpInplace f = fRealBOpInplace' f f++type SomeFReal = SomeFKinded FTReal FReal+deriving stock instance Show SomeFReal+instance Eq  SomeFReal where+    (SomeFKinded l) == (SomeFKinded r) = fRealBOp (==) l r+instance Ord SomeFReal where+    compare (SomeFKinded l) (SomeFKinded r) = fRealBOp compare l r

@@ -0,0 +1,63 @@+{- | Fortran CHAR value representation.++Currently only CHARs of known length.+-}++module Language.Fortran.Repr.Value.Scalar.String where++import GHC.TypeNats+import Language.Fortran.Repr.Compat.Natural+import Data.Text ( Text )+import qualified Data.Text as Text+import Language.Fortran.Repr.Util ( natVal'' )+import Data.Proxy+import Unsafe.Coerce++-- TODO unsafe constructor do not use >:(+-- need context for Reasons(TM)+data FString (l :: NaturalK) = KnownNat l => FString Text+deriving stock instance Show (FString l)+deriving stock instance Eq   (FString l)+deriving stock instance Ord  (FString l) -- TODO++fString :: forall l. KnownNat l => Text -> Maybe (FString l)+fString s =+    if   Text.length s == fromIntegral (natVal'' @l)+    then Just $ FString s+    else Nothing++fStringLen :: forall l. KnownNat l => FString l -> Natural+fStringLen _ = natVal'' @l++data SomeFString = forall (l :: NaturalK). KnownNat l => SomeFString (FString l)+deriving stock instance Show SomeFString+instance Eq SomeFString where+    (SomeFString (FString sl)) == (SomeFString (FString sr)) = sl == sr++someFString :: Text -> SomeFString+someFString s =+    case someNatVal (fromIntegral (Text.length s)) of+      SomeNat (_ :: Proxy n) -> SomeFString $ FString @n s++someFStringLen :: SomeFString -> Natural+someFStringLen (SomeFString s) = fStringLen s++-- TODO dunno how to do this without unsafeCoerce because of the type-level nat+-- addition >:( -- oh actually seems this is an expected usage of it. ok+concatFString+    :: forall ll lr. (KnownNat ll, KnownNat lr)+    => FString ll+    -> FString lr+    -> FString (ll + lr)+concatFString (FString sl) (FString sr) =+    unsafeCoerce $ FString @ll $ sl <> sr++concatSomeFString :: SomeFString -> SomeFString -> SomeFString+concatSomeFString (SomeFString l) (SomeFString r) =+    case concatFString l r of s@FString{} -> SomeFString s++fStringBOp :: (Text -> Text -> r) -> FString ll -> FString lr -> r+fStringBOp f (FString l) (FString r) = f l r++someFStringBOp :: (Text -> Text -> r) -> SomeFString -> SomeFString -> r+someFStringBOp f (SomeFString l) (SomeFString r) = fStringBOp f l r

@@ -1,5 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}- module Language.Fortran.Transformation.Disambiguation.Function (disambiguateFunction) where  import Prelude hiding (lookup)

@@ -1,5 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-}- module Language.Fortran.Transformation.Disambiguation.Intrinsic (disambiguateIntrinsic) where  import Prelude hiding (lookup)

@@ -14,8 +14,6 @@    limitations under the License. -} -{-# LANGUAGE ScopedTypeVariables #-}- {-|  Format of Camfort precompiled files with information about Fortran

@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} module Language.Fortran.Analysis.DataFlowSpec where  import Test.Hspec

@@ -166,6 +166,10 @@         resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer foo ! bar")           `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TEOF u] +      it "lexes inline comments as blocks when possible" $+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "\n      ! Block")+          `shouldBe` resetSrcSpan [TNewline u, TComment u " Block", TEOF u]+       it "lexes continuation lines separated by comments" $ do         let src = unlines [ "      integer foo,"                           , "C hello"@@ -290,11 +294,11 @@         resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`           resetSrcSpan [ TId u "l", TOpAssign u, TId u "r", TNewline u                        , TId u "r", TOpAssign u, TId u "l", TNewline u, TEOF u]-      it "lexel comment line overflow" $ do+      it "lexes all comment line even with overflow" $ do         let src = unlines [ replicate 80 'c'                           , "      l = r" ]         resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`-          resetSrcSpan [ TComment u (replicate 71 'c'), TNewline u+          resetSrcSpan [ TComment u (replicate 79 'c'), TNewline u                        , TId u "l", TOpAssign u, TId u "r", TNewline u, TEOF u]  example1 :: String

@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}  module Language.Fortran.PrettyPrintSpec where

@@ -148,6 +148,8 @@         "replacementsmap-overlapping-filtered"         ["001_foo.f"]       overlapping `shouldBe` [r2]+#ifndef FS_DISABLE_WIN_BROKEN_TESTS+    -- TODO fails on Windows, perhaps problem with temp files or filenames?     it "Process ReplacementMap (invalid range; start line)" $ do       base <- getCurrentDirectory       let@@ -222,7 +224,6 @@                   "999999999999999999999"               ]             )-#ifndef FS_DISABLE_WIN_BROKEN_TESTS           -- TODO fails on Windows due to some line ending/spacing bug           , ( workDir ++ "002_other.f"             , [ Replacement@@ -237,7 +238,6 @@                   "9 .and. \n     + 4 .lt. 4\n     + .or. .true."               ]             )-#endif           , ( workDir ++ "004_comment.f"             , [ Replacement                 (SourceRange (SourceLocation 2 18) (SourceLocation 2 19))@@ -293,14 +293,13 @@         Nothing         "replacementsmap-columnlimit"         [ "001_foo.f"-#ifndef FS_DISABLE_WIN_BROKEN_TESTS         , "002_other.f"         , "003_multiline.f"-#endif         , "004_comment.f"         , "005_removals.f"         , "006_linewrap_heuristic.f"         ]+#endif    describe "Filtering overlapping replacements" $ do     it "Simple overlap" $ do