fortran-src 0.12.0 → 0.13.0

raw patch · 44 files changed

+942/−1042 lines, 44 filesdep +processPVP ok

version bump matches the API change (PVP)

Dependencies added: process

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−1
• README.md +9/−1
• app/Main.hs +13/−7
• fortran-src.cabal +8/−5
• src/Language/Fortran/Analysis.hs +5/−16
• src/Language/Fortran/Analysis/DataFlow.hs +18/−34
• src/Language/Fortran/Analysis/ModGraph.hs +3/−3
• src/Language/Fortran/Analysis/SemanticTypes.hs +3/−0
• src/Language/Fortran/Parser/Fixed/Lexer.x +2/−2
• src/Language/Fortran/Parser/Free/Lexer.x +29/−12
• src/Language/Fortran/Parser/Monad.hs +15/−9
• src/Language/Fortran/PrettyPrint.hs +10/−12
• src/Language/Fortran/Repr.hs +7/−4
• src/Language/Fortran/Repr/Eval/Common.hs +22/−10
• src/Language/Fortran/Repr/Eval/Type.hs +3/−1
• src/Language/Fortran/Repr/Eval/Value.hs +139/−115
• src/Language/Fortran/Repr/Eval/Value/Op.hs +37/−46
• src/Language/Fortran/Repr/Eval/Value/Op/Some.hs +0/−177
• src/Language/Fortran/Repr/Type/Scalar.hs +10/−1
• src/Language/Fortran/Repr/Type/Scalar/Common.hs +8/−57
• src/Language/Fortran/Repr/Type/Scalar/Complex.hs +10/−8
• src/Language/Fortran/Repr/Type/Scalar/Int.hs +24/−66
• src/Language/Fortran/Repr/Type/Scalar/Real.hs +10/−31
• src/Language/Fortran/Repr/Type/Scalar/String.hs +5/−13
• src/Language/Fortran/Repr/Value/Array.hs +0/−5
• src/Language/Fortran/Repr/Value/Array/Machine.hs +0/−106
• src/Language/Fortran/Repr/Value/Machine.hs +11/−5
• src/Language/Fortran/Repr/Value/Scalar/Common.hs +85/−1
• src/Language/Fortran/Repr/Value/Scalar/Complex.hs +39/−13
• src/Language/Fortran/Repr/Value/Scalar/Int/Idealized.hs +12/−20
• src/Language/Fortran/Repr/Value/Scalar/Int/Machine.hs +70/−143
• src/Language/Fortran/Repr/Value/Scalar/Logical/Machine.hs +2/−2
• src/Language/Fortran/Repr/Value/Scalar/Machine.hs +20/−12
• src/Language/Fortran/Repr/Value/Scalar/Real.hs +52/−82
• src/Language/Fortran/Repr/Value/Scalar/String.hs +60/−4
• src/Language/Fortran/Util/Files.hs +31/−2
• src/Language/Fortran/Util/ModFile.hs +1/−1
• src/Language/Fortran/Version.hs +7/−7
• src/Text/PrettyPrint/GenericPretty/Orphans.hs +21/−0
• src/Text/PrettyPrint/GenericPretty/ViaShow.hs +31/−0
• test/Language/Fortran/Analysis/DataFlowSpec.hs +0/−7
• test/Language/Fortran/Parser/Free/LexerSpec.hs +40/−1
• test/Language/Fortran/PrettyPrintSpec.hs +13/−0
• test/Language/Fortran/Repr/EvalSpec.hs +43/−0

@@ -1,4 +1,17 @@-### Unreleased (major ver.)+### 0.13.0 (Mar 14, 2023)+  * better handling for line directives in free form lexer (#248, @mrd)+  * don't inline solo includes in relevant F77 parsers (#245, @RaoulHC)+  * add `-C=opts` CLI option for passing CPP arguments (#250, @mrd)+  * fix reformatting of 73 character long lines in naive mixed form reformatter+    (#251, @ksromanov)+  * assume extended `Fortran77Legacy` rather than `Fortran77` for `*.f`, `*.for`+    etc. files (#260)+  * allow comment lines between continuation lines in F77 parser (in standard)+    (#257, @RaoulHC)+  * refactor Fortran type & value representation & expression evaluator without+    Fortran kind-indexed GADTs; replace constant folder (#253, @raehik)++### 0.12.0 (Oct 19, 2022)   * clean up F77 include inlining (#245, @RaoulHC)     * directly export F77 include parser at `f77lIncludesNoTransform`     * `f77lIncIncludes :: String -> ByteString -> IO [Block A0]` should now be

@@ -40,7 +40,7 @@ ``` Usage: fortran-src [OPTION...] <file>   -v VERSION, -F VERSION  --fortranVersion=VERSION         Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]-  -a ACTION               --action=ACTION                  lex or parse action+  -a ACTION               --action=ACTION                  choose the action, possible values: lex|parse   -t                      --typecheck                      parse and run typechecker   -R                      --rename                         parse and rename variables   -B                      --bblocks                        analyse basic blocks@@ -54,6 +54,14 @@                           --show-flows-to=AST-BLOCK-ID     dump a graph showing flows-to information from the given AST-block ID; prefix with 's' for supergraph                           --show-flows-from=AST-BLOCK-ID   dump a graph showing flows-from information from the given AST-block ID; prefix with 's' for supergraph ```++If you do not pass a `--fortranVersion` flag, the version will be guessed from+the file name:++  * Files ending in `*.f` are parsed with extended FORTRAN 77 syntax.+  * Files ending in `*.f90` are parsed with Fortran 90 syntax (and respectively+    for `*.f2003`/`*.f03`, `*.f2008`/`*.f08`).+  * Unknown extensions are parsed like `*.f` files.  ## Building You will need the GMP library plus header files: on many platforms, this will be

@@ -57,14 +57,14 @@   case (parsedArgs, action opts) of     (paths, ShowMakeGraph) -> do       paths' <- expandDirs paths-      mg <- genModGraph (fortranVersion opts) (includeDirs opts) paths'+      mg <- genModGraph (fortranVersion opts) (includeDirs opts) (cppOptions opts) paths'       putStrLn $ modGraphToDOT mg     -- make: construct a build-dep graph and follow it     (paths, Make) -> do       let mvers = fortranVersion opts       paths' <- expandDirs paths       -- Build the graph of module dependencies-      mg0 <- genModGraph mvers (includeDirs opts) paths'+      mg0 <- genModGraph mvers (includeDirs opts) (cppOptions opts) paths'       -- Start the list of mods with those from the command line       mods0 <- decodeModFiles' $ includeDirs opts       -- Loop through the dependency graph until it is empty@@ -101,7 +101,7 @@       mods <- decodeModFiles' $ includeDirs opts       mapM_ (\ p -> compileFileToMod (fortranVersion opts) mods p (outputFile opts)) paths     (path:_, actionOpt) -> do-      contents <- flexReadFile path+      contents <- runCPP (cppOptions opts) path -- only runs CPP if cppOptions is not Nothing       mods <- decodeModFiles' $ includeDirs opts       let version   = fromMaybe (deduceFortranVersion path) (fortranVersion opts)           parsedPF  = case (Parser.byVerWithMods mods version) path contents of@@ -205,7 +205,6 @@         _ -> fail $ usageInfo programName options     _ -> fail $ usageInfo programName options - -- | Expand all paths that are directories into a list of Fortran -- files from a recursive directory listing. expandDirs :: [FilePath] -> IO [FilePath]@@ -271,7 +270,7 @@   where     gr' = superBBGrGraph sgr     entries = superBBGrEntries sgr-    dfStr gr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [+    dfStr gr = (\ (l, x) -> "\n********************\n  " ++ l ++ ": " ++ "\n--------------------\n" ++ x ++ "\n") =<< [                  ("callMap",      show cm)                , ("entries",      show (bbgrEntries gr))                , ("exits",        show (bbgrExits gr))@@ -349,11 +348,12 @@   , outputFormat    :: OutputFormat   , outputFile      :: Maybe FilePath   , includeDirs     :: [String]+  , cppOptions      :: Maybe String -- ^ Nothing: no CPP; Just x: run CPP with options x.   , useContinuationReformatter :: Bool   }  initOptions :: Options-initOptions = Options Nothing Parse Default Nothing [] False+initOptions = Options Nothing Parse Default Nothing [] Nothing False  options :: [OptDescr (Options -> Options)] options =@@ -364,7 +364,7 @@   , Option ['a']       ["action"]       (ReqArg (\a opts -> opts { action = read a }) "ACTION")-      "lex or parse action"+      "choose the action, possible values: lex|parse"   , Option ['t']       ["typecheck"]       (NoArg $ \ opts -> opts { action = Typecheck })@@ -397,6 +397,12 @@       ["dump-mod-file"]       (NoArg $ \ opts -> opts { action = DumpModFile })       "dump the information contained within mod files"+  , Option ['C']+      ["cpp"]+      (OptArg (\ cppOpts opts -> opts {+                  cppOptions = Just (dropWhile (=='=') $ fromMaybe "" cppOpts) }+              ) "CPP-OPTS")+      "run the C Pre Processor on the Fortran files first"   , Option ['I']       ["include-dir"]       (ReqArg (\ d opts -> opts { includeDirs = d:includeDirs opts }) "DIR")

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           fortran-src-version:        0.12.0+version:        0.13.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@@ -102,7 +102,6 @@       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@@ -114,8 +113,6 @@       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@@ -142,6 +139,8 @@       Language.Fortran.Util.Position       Language.Fortran.Util.SecondParameter       Language.Fortran.Version+      Text.PrettyPrint.GenericPretty.Orphans+      Text.PrettyPrint.GenericPretty.ViaShow   other-modules:       Paths_fortran_src   hs-source-dirs:@@ -195,6 +194,7 @@     , filepath ==1.4.*     , mtl >=2.2 && <3     , pretty >=1.1 && <2+    , process >=1.2.0.0     , singletons >=3.0 && <3.2     , singletons-base >=3.0 && <3.2     , singletons-th >=3.0 && <3.2@@ -259,6 +259,7 @@     , fortran-src     , mtl >=2.2 && <3     , pretty >=1.1 && <2+    , process >=1.2.0.0     , singletons >=3.0 && <3.2     , singletons-base >=3.0 && <3.2     , singletons-th >=3.0 && <3.2@@ -294,6 +295,7 @@       Language.Fortran.Parser.Free.LexerSpec       Language.Fortran.Parser.MonadSpec       Language.Fortran.PrettyPrintSpec+      Language.Fortran.Repr.EvalSpec       Language.Fortran.Rewriter.InternalSpec       Language.Fortran.RewriterSpec       Language.Fortran.Transformation.Disambiguation.FunctionSpec@@ -355,6 +357,7 @@     , hspec >=2.2 && <3     , mtl >=2.2 && <3     , pretty >=1.1 && <2+    , process >=1.2.0.0     , singletons >=3.0 && <3.2     , singletons-base >=3.0 && <3.2     , singletons-th >=3.0 && <3.2

@@ -3,7 +3,7 @@ -- | -- Common data structures and functions supporting analysis of the AST. module Language.Fortran.Analysis-  ( initAnalysis, stripAnalysis, Analysis(..), Constant(..)+  ( initAnalysis, stripAnalysis, Analysis(..)   , varName, srcName, lvVarName, lvSrcName, isNamedExpression   , genVar, puName, puSrcName, blockRhsExprs, rhsExprs   , ModEnv, NameType(..), IDType(..), ConstructType(..)@@ -31,6 +31,8 @@  import           Language.Fortran.Analysis.SemanticTypes (SemType(..)) +import Language.Fortran.Repr+ --------------------------------------------------  -- | Basic block@@ -105,18 +107,6 @@ instance Out IDType instance Binary IDType --- | Information about potential / actual constant expressions.-data Constant-  = ConstInt Integer            -- ^ interpreted integer-  | ConstUninterpInt String     -- ^ uninterpreted integer-  | ConstUninterpReal String    -- ^ uninterpreted real-  | ConstBinary BinaryOp Constant Constant -- ^ binary operation on potential constants-  | ConstUnary UnaryOp Constant -- ^ unary operation on potential constants-  deriving (Show, Ord, Eq, Typeable, Generic, Data)--instance Out Constant-instance Binary Constant- data Analysis a = Analysis   { prevAnnotation :: a -- ^ original annotation   , uniqueName     :: Maybe String -- ^ unique name for function/variable, after variable renaming phase@@ -126,9 +116,8 @@   , moduleEnv      :: Maybe ModEnv   , idType         :: Maybe IDType   , allLhsVarsAnn  :: [Name]-  , constExp       :: Maybe Constant-  }-  deriving (Data, Show, Eq, Generic)+  , constExp       :: Maybe FValue+  } deriving stock (Show, Generic, Data, Eq)  instance Functor Analysis where   fmap f analysis =

@@ -8,7 +8,7 @@   , genUDMap, genDUMap, duMapToUdMap, UDMap, DUMap   , genFlowsToGraph, FlowsGraph   , genVarFlowsToMap, VarFlowsMap-  , Constant(..), ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars, constantFolding+  , ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars   , genBlockMap, genDefMap, BlockMap, DefMap   , genCallMap, CallMap   , loopNodes, genBackEdgeMap, sccWith, BackEdgeMap@@ -43,6 +43,9 @@ import Data.List (foldl', foldl1', (\\), union, intersect) import Control.Monad.Writer hiding (fix) +import qualified Language.Fortran.Repr as Repr+import qualified Language.Fortran.Repr.Eval.Value as Repr+ -------------------------------------------------- -- Better names for commonly used types type BBNodeMap = IM.IntMap@@ -354,30 +357,13 @@ inBounds :: Integer -> Bool inBounds x = minConst <= x && x <= maxConst --- | Evaluate possible constant expressions within tree.-constantFolding :: Constant -> Constant-constantFolding c = case c of-  ConstBinary binOp a b | ConstInt x <- constantFolding a-                        , ConstInt y <- constantFolding b -> case binOp of-    Addition       | inBounds (x + y) -> ConstInt (x + y)-    Subtraction    | inBounds (x - y) -> ConstInt (x - y)-    Multiplication | inBounds (x * y) -> ConstInt (x * y)-    Division       | y /= 0           -> ConstInt (x `div` y)-    -- gfortran appears to do real exponentiation (allowing negative exponent)-    -- and cast back to integer via floor() (?) as required-    -- but we keep it simple & stick with Haskell-style integer exponentiation-    Exponentiation | y >= 0           -> ConstInt (x ^ y)-    _                                 -> ConstBinary binOp (ConstInt x) (ConstInt y)-  ConstUnary Minus a | ConstInt x <- constantFolding a -> ConstInt (-x)-  ConstUnary Plus  a                                   -> constantFolding a-  _ -> c- -- | The map of all parameter variables and their corresponding values-type ParameterVarMap = M.Map Name Constant+type ParameterVarMap = M.Map Name Repr.FValue+ -- | The map of all expressions and whether they are undecided (not--- present in map), a constant value (Just Constant), or probably not--- constant (Nothing).-type ConstExpMap = ASTExprNodeMap (Maybe Constant)+-- present in map), a constant value ('Just'), or probably not+-- constant ('Nothing').+type ConstExpMap = ASTExprNodeMap (Maybe Repr.FValue)  -- | Generate a constant-expression map with information about the -- expressions (identified by insLabel numbering) in the ProgramFile@@ -394,23 +380,21 @@       [ (varName v, getE e)       | st@StParameter{} <- universeBi pf :: [Statement (Analysis a)]       , (Declarator _ _ v ScalarDecl _ (Just e)) <- universeBi st ]-    getV :: Expression (Analysis a) -> Maybe Constant+    getV :: Expression (Analysis a) -> Maybe Repr.FValue     getV e = constExp (getAnnotation e) `mplus` (join . flip M.lookup pvMap . varName $ e)      -- Generate map of information about 'constant expressions'.     ceMap = IM.fromList [ (label, doExpr e) | e <- universeBi pf, Just label <- [labelOf e] ]-    getE :: Expression (Analysis a) -> Maybe Constant+    getE :: Expression (Analysis a) -> Maybe Repr.FValue     getE = join . (flip IM.lookup ceMap <=< labelOf)     labelOf = insLabel . getAnnotation-    doExpr :: Expression (Analysis a) -> Maybe Constant-    doExpr e = case e of-      ExpValue _ _ (ValInteger intStr _) -> Just . ConstInt $ read intStr-      ExpValue _ _ (ValReal r _)    -> Just $ ConstUninterpReal (prettyHsRealLit r) -- TODO-      ExpValue _ _ (ValVariable _)  -> getV e-      -- Recursively seek information about sub-expressions, relying on laziness.-      ExpBinary _ _ binOp e1 e2     -> constantFolding <$> liftM2 (ConstBinary binOp) (getE e1) (getE e2)-      ExpUnary _ _ unOp e'           -> constantFolding <$> ConstUnary unOp <$> getE e'-      _ -> Nothing+    doExpr :: Expression (Analysis a) -> Maybe Repr.FValue+    doExpr e =+        -- TODO constants may use other constants! but genConstExpMap needs more+        -- changes to support that+        case Repr.runEvalFValuePure mempty (Repr.evalExpr e) of+          Left _err -> Nothing+          Right (a, _msgs) -> Just a  -- | Get constant-expression information and put it into the AST -- analysis annotation. Must occur after analyseBBlocks.

@@ -61,8 +61,8 @@   mg@ModGraph { mgGraph = gr } <- get   put $ mg { mgGraph = insEdge (i, j, ()) gr } -genModGraph :: Maybe FortranVersion -> [FilePath] -> [FilePath] -> IO ModGraph-genModGraph mversion includeDirs paths = do+genModGraph :: Maybe FortranVersion -> [FilePath] -> Maybe String -> [FilePath] -> IO ModGraph+genModGraph mversion includeDirs cppOpts paths = do   let perModule path pu@(PUModule _ _ modName _ _) = do         _ <- maybeAddModName modName (Just $ MOFile path)         let uses = [ usedName | StUse _ _ (ExpValue _ _ (ValVariable usedName)) _ _ _ <-@@ -80,7 +80,7 @@       perModule _ _ = pure ()   let iter :: FilePath -> ModGrapher ()       iter path = do-        contents <- liftIO $ flexReadFile path+        contents <- liftIO $ runCPP cppOpts path         fileMods <- liftIO $ decodeModFiles includeDirs         let version = fromMaybe (deduceFortranVersion path) mversion             mods = map snd fileMods

@@ -63,6 +63,9 @@ -- | The declared dimensions of an array variable. -- -- Each dimension is of the form @(dim_lower, dim_upper)@.+--+-- This type should not be used to represent assumed-shape arrays, introduced in+-- F90. They may be represented like @[Int]@ (known rank, known lower bounds). data Dimensions   = DimensionsCons !(Int, Int) Dimensions   -- ^ Another dimension in the dimension list.

@@ -943,8 +943,8 @@   | posAbsoluteOffset _position == aiEndOffset ai = Nothing   -- Skip the continuation line altogether   | isContinuation ai && _isWhiteInsensitive = skip Continuation ai-  -- Skip the newline before a comment-  | aiFortranVersion ai == Fortran77Legacy && _isWhiteInsensitive+  -- Skip comment lines "between" continuations+  | aiFortranVersion ai >= Fortran77 && _isWhiteInsensitive   && isNewlineCommentsFollowedByContinuation ai = skip NewlineComment ai   -- If we are not parsing a Hollerith skip whitespace   | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai

@@ -88,7 +88,7 @@ <0> "/*"                                          { skipCComment } <0,scN> "!".*$                                    { adjustComment $ addSpanAndMatch TComment } -<0> $hash.*$                                      { lexHash }+<0> $hash.*(\n\r|\r\n|\n)                         { resetPar >> toSC 0 >> lexHash }  <0,scN,scT> (\n\r|\r\n|\n)                        { resetPar >> toSC 0 >> addSpan TNewline } <0,scN,scI,scT> [\t\ ]+                           ;@@ -1050,6 +1050,8 @@         then _advance ai 3         else if _curChar == '!'         then _advance ai 2+        else if _curChar == '#'+        then _pragma ai ""         else if _curChar == '&'         -- This state accepts as if there were no spaces between the broken         -- line and whatever comes after second &. This is implicitly state (4)@@ -1065,7 +1067,15 @@       case advanceWithoutContinuation ai of         Just ai'' -> _skipCont ai'' state         Nothing -> error "File has ended prematurely during a continuation."+    -- special handling for line pragmas inside continuations+    _pragma ai revstr =+       if currentChar ai == '\n'+       then _advance (processLinePragma (reverse revstr) ai) (3 :: Integer)+       else case advanceWithoutContinuation ai of+         Just ai'' -> _pragma ai'' (currentChar ai:revstr)+         Nothing -> error "File has ended prematurely during a continuation." + -- skip a C comment (read until first "*/") skipCComment :: LexAction (Maybe Token) skipCComment = do@@ -1093,22 +1103,29 @@     _line = posLine position     _absl = posAbsoluteOffset position --- Handle pragmas that begin with #-lexHash :: LexAction (Maybe Token)-lexHash = do-  ai <- getAlex-  m <- getMatch-  case words (drop 1 m) of+processLinePragma :: String -> AlexInput -> AlexInput+processLinePragma m ai =+  case dropWhile ((`elem` ["#", "line", "#line"]) . map toLower) (words m) of     -- 'line' pragma - rewrite the current line and filename-    "line":lineStr:_+    lineStr:otherWords       | line <- readIntOrBoz lineStr -> do         let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"")-        let file       = revdropWNQ . revdropWNQ $ m-        let lineOffs   = fromIntegral line - posLine (aiPosition ai) - 1+        let file       = revdropWNQ . revdropWNQ $ unwords otherWords+        -- if a newline is present, then the aiPosition is already on the next line+        let maybe1 | elem '\n' m = 0 | otherwise = 1+        -- lineOffs is the difference between the given line and the current next line+        let lineOffs   = fromIntegral line - (posLine (aiPosition ai) + maybe1)         let newP       = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file)                                          , posColumn = 1 }-        putAlex $ ai { aiPosition = newP }-    _ -> return ()+        ai { aiPosition = newP }+    _ -> ai++-- Handle pragmas that begin with #+lexHash :: LexAction (Maybe Token)+lexHash = do+  ai <- getAlex+  let m = reverse . lexemeMatch . aiLexeme $ ai+  putAlex $ processLinePragma m ai   return Nothing  --------------------------------------------------------------------------------

@@ -78,9 +78,22 @@  newtype Parse b c a = Parse { unParse :: ParseState b -> ParseResult b c a } -instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where-  return a = Parse $ \s -> ParseOk a s+instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where+  fmap f (Parse p) = Parse $ \s -> case p s of+    ParseOk a s' -> ParseOk (f a) s'+    ParseFailed e -> ParseFailed e +instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where+  pure a = Parse $ \s -> ParseOk a s+  (Parse pl) <*> (Parse pr) = Parse $ \s ->+    case pl s of+      ParseFailed e -> ParseFailed e+      ParseOk ab s' ->+        case pr s' of+          ParseFailed e -> ParseFailed e+          ParseOk a s'' -> ParseOk (ab a) s''++instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where   (Parse m) >>= f = Parse $ \s ->     case m s of       ParseOk a s' -> unParse (f a) s'@@ -97,13 +110,6 @@     , errLastToken  = (getLastToken . psAlexInput) s     , errFilename   = psFilename s     , errMsg        = msg }--instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where-  fmap = liftM--instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where-  pure  = return-  (<*>) = ap  instance (Loc b, LastToken b c, Show c) => MonadState (ParseState b) (Parse b c) where   get = Parse $ \s -> ParseOk s s

@@ -1134,7 +1134,11 @@ -- Ensures that no non-comment line exceeds 72 columns. -- -- The reformatting should be compatible with fixed and free-form Fortran--- standards. See: http://fortranwiki.org/fortran/show/Continuation+lines+-- standards, so called `intersection` format. In this format the+-- last statement character should not be placed after column 72, however+-- continuation character should be put at column 73 (it should be ignored in+-- fixed-form language)+-- See: http://fortranwiki.org/fortran/show/Continuation+lines -- -- This is a simple, delicate algorithm that must only be used on pretty printer -- output, due to relying on particular parser & pretty printer behaviour. In@@ -1165,17 +1169,11 @@      -- in statement: break when required     go (RefmtStStmt col)    (x:xs)-      | col == maxCol =-            -- lookahead: if next is newline or EOF, we don't need to break-            case xs of-                []   -> x : go (RefmtStStmt (col+1)) xs-                x':_ ->-                    case x' of-                        '\n' -> x : go (RefmtStStmt (col+1)) xs-                        _    ->-                            -- pretend to continue, but we know that we'll break-                            -- on newline next-                            '&' : go (RefmtStStmt (col+1)) ("\n     &" ++ x:xs)+      -- Checking if we are at column 73, since col is counted from 0!+      | col == maxCol && x == '&' = -- already a continuation in `intersection` format+                        '&' : go (RefmtStStmt (col+1)) xs+      | col == maxCol = -- making continuation+                        '&' : '\n' : go stNewline ("     &" ++ x:xs)       | otherwise     = x : go (RefmtStStmt (col+1)) xs      maxCol = 72

@@ -11,6 +11,13 @@ 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.++TODO++  * Data (SYB) doesn't play nice with GADTs. They *are* entirely possible+    together with singletons, but remain extremely finicky. It was a source of+    issues during development. So no nice GADTs :(+ -}  module Language.Fortran.Repr@@ -28,7 +35,6 @@   -- * 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@@ -38,7 +44,6 @@    -- ** 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@@ -49,7 +54,6 @@   ) 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@@ -58,7 +62,6 @@ 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

@@ -1,23 +1,35 @@+-- | Common Fortran evaluation definitions.+ 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.+{- | Monads which provide functionality to evaluate Fortran expressions in some+     static context. -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.+Actions in this monad may -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@).+  * request the value of a variable (may return 'Nothing' if not in scope)+  * record some user-facing information concerning evaluation++As usage examples, a simple pure evaluator may use a plain map of 'F.Name' to+@'EvalTo' m@. A more complex type evaluator may allow "defaulting" for variables+not in scope via IMPLICIT rules.++The associated type family 'EvalTo' enables using this for both type and value+evaluators. -}-class Monad m => MonadEval m where+class Monad m => MonadFEval m where     -- | Target type that we evaluate to.     type EvalTo m++    -- | Request the value of a variable.+    --+    -- Returns 'Nothing' if the variable is not in scope.     lookupFVar :: F.Name -> m (Maybe (EvalTo m)) -    -- | Arbitrarily record some user-facing information concerning evaluation.+    -- | Record some user-facing information concerning evaluation.     ---    -- For example, potentially useful when making defaulting decisions.+    -- For example, you may want to inform the user when you've made a+    -- defaulting decision.     warn :: String -> m ()

@@ -7,10 +7,12 @@ import Language.Fortran.Repr.Eval.Common  fromExpression-    :: forall m a. (MonadEval m, EvalTo m ~ FType)+    :: forall m a. (MonadFEval 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++-- TODO support for IMPLICIT rules

@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingVia #-}  -- | Evaluate AST terms to values in the value representation. @@ -18,6 +19,8 @@ import Language.Fortran.Repr.Value.Scalar.String  import Language.Fortran.Repr.Type ( FType )+import Language.Fortran.Repr.Type.Scalar.Common ( FKindLit )+import Language.Fortran.Repr.Type.Scalar ( fScalarTypeKind )  import Language.Fortran.Repr.Eval.Common import qualified Language.Fortran.Repr.Eval.Value.Op as Op@@ -29,20 +32,19 @@  import Control.Monad.Except --- simple implementation+import Data.Word ( Word8 )++-- pure 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.+-- | Error encountered while evaluating a Fortran expression to a value. data Error   = ENoSuchVar F.Name   | EKindLitBadType F.Name FType-  | ENoSuchKindForType String KindLit+  | ENoSuchKindForType String FKindLit   | EUnsupported String   | EOp Op.Error   | EOpTypeError String@@ -50,35 +52,48 @@   -- ^ Catch-all for non-grouped errors.     deriving stock (Generic, Show, Eq) --- TODO best for temp KPs: String, Integer, Text? Word8??-type KindLit = String+-- | A convenience constraint tuple defining the base requirements of the+--   'FValue' evaluator.+--+-- The evaluator is formed of combinators returning values in this monad. You+-- may insert your own evaluator which handles monadic actions differently,+-- provided it can fulfill these constraints.+type MonadFEvalValue m = (MonadFEval m, EvalTo m ~ FValue, MonadError Error m)  -------------------------------------------------------------------------------- +-- | derivingvia helper+type FEvalValuePureT = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))+ -- | A simple pure interpreter for Fortran value evaluation programs.-type EvalValueSimple = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))+newtype FEvalValuePure a = FEvalValuePure { unFEvalValuePure :: WriterT [String] (ExceptT Error (Reader (Map F.Name FValue))) a }+    deriving (Functor, Applicative, Monad) via FEvalValuePureT+    deriving (MonadReader (Map F.Name FValue)) via FEvalValuePureT+    deriving (MonadWriter [String]) via FEvalValuePureT+    deriving (MonadError Error) via FEvalValuePureT -instance MonadEval EvalValueSimple where-    type EvalTo EvalValueSimple = FValue+instance MonadFEval FEvalValuePure where+    type EvalTo FEvalValuePure = FValue     warn msg = tell [msg]     lookupFVar nm = do         m <- ask         pure $ Map.lookup nm m -runEvalValueSimple+runEvalFValuePure     :: Map F.Name FValue-    -> EvalValueSimple a -> Either Error (a, [String])-runEvalValueSimple m = flip runReader m . runExceptT . runWriterT+    -> FEvalValuePure a -> Either Error (a, [String])+runEvalFValuePure m =+    flip runReader m . runExceptT . runWriterT . unFEvalValuePure  -------------------------------------------------------------------------------- -evalVar :: MonadEvalValue m => F.Name -> m FValue+evalVar :: MonadFEvalValue m => F.Name -> m FValue evalVar name =     lookupFVar name >>= \case       Nothing  -> err $ ENoSuchVar name-      Just val -> return val+      Just val -> pure val -evalExpr :: MonadEvalValue m => F.Expression a -> m FValue+evalExpr :: MonadFEvalValue m => F.Expression a -> m FValue evalExpr = \case   F.ExpValue _ _ astVal ->     case astVal of@@ -107,27 +122,27 @@   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 :: MonadFEvalValue 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+    evalMKp 4 mkp >>= \case+      4 -> pure $ FSVInt $ FInt4 $ read i+      8 -> pure $ FSVInt $ FInt8 $ read i+      2 -> pure $ FSVInt $ FInt2 $ read i+      1 -> pure $ FSVInt $ 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+      4 -> pure $ FSVReal $ FReal4 $ F.readRealLit r+      8 -> pure $ FSVReal $ 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+    evalMKp 4 mkp >>= \case+      4 -> pure $ FSVLogical $ FInt4 $ fLogicalNumericFromBool b+      8 -> pure $ FSVLogical $ FInt8 $ fLogicalNumericFromBool b+      2 -> pure $ FSVLogical $ FInt2 $ fLogicalNumericFromBool b+      1 -> pure $ FSVLogical $ 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@@ -136,11 +151,11 @@     -- 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.ValString s -> pure $ FSVString $ 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+    pure $ FSVInt $ FInt4 $ F.bozAsTwosComp boz+  F.ValHollerith s -> pure $ FSVString $ 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"@@ -152,58 +167,53 @@ 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+evalKp :: MonadFEvalValue m => F.KindParam a -> m FKindLit+evalKp = \case+  F.KindParamInt _ _ k ->+    -- TODO we may wish to check kind param sensibility here+    -- easy check is length (<=3)+    -- to catch the rest, we may need to read to Int16 and check.+    -- slow and unideal so for now let's assume no bad play such as INTEGER(256)+    pure $ read k+  F.KindParamVar _ _ var ->+    lookupFVar var >>= \case+      Just val -> case val of+        MkFScalarValue (FSVInt i) ->+          pure $ fIntUOp fromIntegral i+        _ -> err $ EKindLitBadType var (fValueType val)+      Nothing  -> err $ ENoSuchVar var +evalMKp :: MonadFEvalValue m => FKindLit -> Maybe (F.KindParam a) -> m FKindLit+evalMKp kDef = \case+  Nothing -> pure kDef+  Just kp -> evalKp kp+ -- 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+evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam a) -> m FKindLit+evalRealKp l = \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)"+        pure 8+  Just kp -> do+    k <- evalKp kp+    case l of+      F.ExpLetterE -> -- @1.2E3_8@ syntax is permitted: use @_8@ kind param+        pure k+      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 k+      F.ExpLetterQ -> do+        warn "TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"+        pure 8 -evalUOp :: MonadEvalValue m => F.UnaryOp -> FValue -> m FValue+evalUOp :: MonadFEvalValue m => F.UnaryOp -> FValue -> m FValue evalUOp op v = do     v' <- forceScalar v     case op of@@ -211,28 +221,28 @@       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+          FSVLogical bi ->+            pure $ MkFScalarValue $ FSVLogical $ fLogicalNot bi           _ -> err $ EOp $ Op.EBadArgType1 ["LOGICAL"] $ fScalarValueType v'       _ -> err $ EUnsupported $ "operator: " <> show op -wrapOp :: MonadEvalValue m => Either Op.Error a -> m a+wrapOp :: MonadFEvalValue m => Either Op.Error a -> m a wrapOp = \case-  Right a -> return a+  Right a -> pure 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 :: MonadFEvalValue m => Either Op.Error FScalarValue -> m FValue wrapSOp = \case-  Right a -> return $ MkFScalarValue a+  Right a -> pure $ 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 :: MonadFEvalValue m => F.BinaryOp -> FValue -> FValue -> m FValue evalBOp bop l r = do     -- TODO also see evalExpr: implement short-circuit eval here     l' <- forceScalar l@@ -246,13 +256,16 @@       -- 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"+      -- TODO basic - ints only. probably should support floats too.+      F.Exponentiation ->+        case (l', r') of+          (FSVInt li, FSVInt ri) ->+            pure $ MkFScalarValue $ FSVInt $ fIntBOpInplace (^) li ri        F.Concatenation  ->         case (l', r') of           (FSVString ls, FSVString rs) ->-            return $ MkFScalarValue $ FSVString $ concatSomeFString ls rs+            pure $ MkFScalarValue $ FSVString $ ls <> rs           _ -> err $ ELazy "concat strings only please"        F.GT  -> defFLogical <$> wrapOp (Op.opIcNumRelBOp (>)  l' r')@@ -278,12 +291,21 @@  defFLogical :: Bool -> FValue defFLogical =-    MkFScalarValue . FSVLogical . SomeFKinded . FInt4 . fLogicalNumericFromBool+    MkFScalarValue . FSVLogical . FInt4 . fLogicalNumericFromBool -evalFunctionCall :: MonadEvalValue m => F.Name -> [FValue] -> m FValue+evalFunctionCall :: MonadFEvalValue m => F.Name -> [FValue] -> m FValue evalFunctionCall fname args =     case fname of +      "kind"  -> do+        args' <- forceArgs 1 args+        let [v] = args'+        v' <- forceScalar v+        let t = fScalarValueType v'+        case fScalarTypeKind t of+          Nothing -> err $ ELazy "called kind with non-kinded scalar"+          Just k  -> pure $ MkFScalarValue $ FSVInt $ FInt4 (fromIntegral k)+       "ior"  -> do         args' <- forceArgs 2 args         let [l, r] = args'@@ -298,10 +320,10 @@         let [v] = args'         v' <- forceScalar v         case v' of-          FSVInt (SomeFKinded i) -> do+          FSVInt i -> do             -- TODO better error handling             let c    = Data.Char.chr (fIntUOp fromIntegral i)-            pure $ MkFScalarValue $ FSVString $ someFString $ Text.singleton c+            pure $ MkFScalarValue $ FSVString $ Text.singleton c           _ ->             err $ EOpTypeError $                 "char: expected INT(x), got "<>show (fScalarValueType v')@@ -311,8 +333,8 @@         let [v] = args'         v' <- forceScalar v         case v' of-          FSVInt (SomeFKinded i) -> do-            pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ fIntUOpInplace Data.Bits.complement i+          FSVInt i -> do+            pure $ MkFScalarValue $ FSVInt $ fIntUOpInplace Data.Bits.complement i           _ ->             err $ EOpTypeError $                 "not: expected INT(x), got "<>show (fScalarValueType v')@@ -327,8 +349,8 @@         case v' of           FSVInt{} ->             pure $ MkFScalarValue v'-          FSVReal (SomeFKinded r) ->-            pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ FInt4 $ fRealUOp truncate r+          FSVReal r ->+            pure $ MkFScalarValue $ FSVInt $ FInt4 $ fRealUOp truncate r           _ ->             err $ EOpTypeError $                 "int: unsupported or unimplemented type: "<>show (fScalarValueType v')@@ -341,15 +363,15 @@         case v' of           FSVInt{} ->             pure $ MkFScalarValue v'-          FSVReal (SomeFKinded r) ->-            pure $ MkFScalarValue $ FSVInt $ SomeFKinded $ FInt2 $ fRealUOp truncate r+          FSVReal r ->+            pure $ MkFScalarValue $ FSVInt $ 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 :: MonadFEvalValue m => F.Argument a -> m FValue evalArg (F.Argument _ _ _ ae) =     case ae of       F.ArgExpr        e -> evalExpr e@@ -357,33 +379,35 @@  -------------------------------------------------------------------------------- -forceScalar :: MonadEvalValue m => FValue -> m FScalarValue+-- exists because we used to support arrays (now stripped)+forceScalar :: MonadFEvalValue m => FValue -> m FScalarValue forceScalar = \case-  MkFArrayValue{} -> err $ EUnsupported "no array values in eval for now thx"-  MkFScalarValue v' -> return v'+  MkFScalarValue v' -> pure v' -forceUnconsArg :: MonadEvalValue m => [a] -> m (a, [a])+forceUnconsArg :: MonadFEvalValue m => [a] -> m (a, [a]) forceUnconsArg = \case   []   -> err $ EOpTypeError "not enough arguments"-  a:as -> return (a, as)+  a:as -> pure (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 :: MonadFEvalValue m => Int -> [a] -> m [a] forceArgs numArgs l =     if   length l == numArgs-    then return l+    then pure 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+    :: MonadFEvalValue m => FScalarValue -> FScalarValue -> m FValue+evalIntrinsicIor l r = case (l, r) of+  (FSVInt li, FSVInt ri) -> wrapSOp $ FSVInt <$> Op.opIor li ri+  _ -> err $ ELazy "ior: bad args"  -- https://gcc.gnu.org/onlinedocs/gfortran/MAX.html -- TODO should support arrays! at least for >=F2010 evalIntrinsicMax-    :: MonadEvalValue m => [FValue] -> m FValue+    :: MonadFEvalValue m => [FValue] -> m FValue evalIntrinsicMax = \case   []   -> err $ EOpTypeError "max intrinsic expects at least 1 argument"   v:vs -> do

@@ -2,8 +2,6 @@  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@@ -28,15 +26,15 @@     deriving stock (Show, Eq)  -- https://gcc.gnu.org/onlinedocs/gfortran/DBLE.html#DBLE-opIcDble :: FScalarValue -> Either Error (FReal 'FTReal8)+opIcDble :: FScalarValue -> Either Error FReal opIcDble = \case-  FSVComplex (SomeFKinded c) -> case c of+  FSVComplex c -> case c of     FComplex8  r _i -> rfr8 $ float2Double r     FComplex16 r _i -> rfr8 r-  FSVReal (SomeFKinded r) -> case r of+  FSVReal r -> case r of     FReal4 r'   -> rfr8 $ float2Double r'     FReal8 _r'  -> Right r-  FSVInt (SomeFKinded i) -> rfr8 $ withFInt i+  FSVInt i -> rfr8 $ withFInt i   v -> eBadArgType1 ["COMPLEX", "REAL", "INT"] v   where rfr8 = Right . FReal8 @@ -55,14 +53,14 @@     -> 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+    go (FSVInt l) (FSVInt r) = Right $ FSVInt $ fIntBOpInplace bop l r+    go (FSVInt l) (FSVReal r) =+        Right $ FSVReal $ fRealUOpInplace (\x -> withFInt l `bop` x) r     -- TODO int complex-    go (FSVReal l) (FSVReal r) = Right $ FSVReal $ someFRealBOpWrap bop l r+    go (FSVReal l) (FSVReal r) = Right $ FSVReal $ fRealBOpInplace 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+        Right $ FSVComplex $ fComplexBOpInplace bop (fComplexFromReal l) r  opIcNumericBOpRealIntSep     :: (forall a. Integral  a => a -> a -> a)@@ -70,36 +68,36 @@     -> 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+    go (FSVInt l) (FSVInt r) = Right $ FSVInt $ fIntBOpInplace bopInt l r+    go (FSVInt l) (FSVReal r) =+        Right $ FSVReal $ fRealUOpInplace (\x -> withFInt l `bopReal` x) r     -- TODO int complex-    go (FSVReal l) (FSVReal r) = Right $ FSVReal $ someFRealBOpWrap bopReal l r+    go (FSVReal l) (FSVReal r) = Right $ FSVReal $ fRealBOpInplace 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+        Right $ FSVComplex $ fComplexBOpInplace bopReal (fComplexFromReal 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+    go (FSVInt l) (FSVInt r) = Right $ fIntBOp bop l r+    go (FSVInt l) (FSVReal r) =+        Right $ fRealUOp (\x -> withFInt l `bop` x) r     -- TODO int complex-    go (FSVReal l) (FSVReal r) = Right $ someFRealBOp bop l r+    go (FSVReal l) (FSVReal r) = Right $ fRealBOp 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+    go (FSVString l) (FSVString r) = Right $ l `bop` 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+  FSVInt  v -> Right $ FSVInt  $ fIntUOpInplace  uop v+  FSVReal v -> Right $ FSVReal $ fRealUOpInplace uop v   v -> eBadArgType1 ["INT", "REAL"] v  -- and, or, eqv, neqv@@ -108,37 +106,30 @@     -> FScalarValue -> FScalarValue -> Either Error r opIcLogicalBOp bop = go   where-    go (FSVLogical (SomeFKinded l)) (FSVLogical (SomeFKinded r)) =+    go (FSVLogical l) (FSVLogical 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+    go (FSVInt  l) (FSVInt  r) = Right $ fIntBOp  (==) l r+    go (FSVReal l) (FSVReal r) = Right $ fRealBOp (==) l r+    go (FSVInt i) (FSVReal r) =+        Right $ fRealUOp (\x -> withFInt i == x) r+    go (FSVReal r) (FSVInt i) =+        Right $ fRealUOp (\x -> withFInt i == x) r+    go (FSVString l) (FSVString r) = Right $ l == r  -- | According to gfortran spec and F2010 spec, same kind required.-opIor' :: FInt k -> FInt k -> FInt k+opIor' :: FInt -> FInt -> FInt opIor' = fIntBOpInplace (.|.) -opIor :: FScalarValue -> FScalarValue -> Either Error SomeFInt-opIor (FSVInt (SomeFKinded l)) (FSVInt (SomeFKinded r)) =+opIor :: FInt -> FInt -> Either Error FInt+opIor l 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+      (FInt4{}, FInt4{}) -> Right $ opIor' l r+      (FInt8{}, FInt8{}) -> Right $ opIor' l r+      (FInt2{}, FInt2{}) -> Right $ opIor' l r+      (FInt1{}, FInt1{}) -> Right $ opIor' l r+      _ -> Left $ EGeneric "bad args to ior"

@@ -1,177 +0,0 @@-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

@@ -30,5 +30,14 @@   FSTString  l -> "CHARACTER("<>prettyCharLen l<>")"   FSTCustom  t -> "TYPE("<>t<>")" -prettyKinded :: FKinded a => a -> String -> String+fScalarTypeKind :: FScalarType -> Maybe FKindLit+fScalarTypeKind = \case+  FSTInt     k -> Just $ printFKind k+  FSTReal    k -> Just $ printFKind k+  FSTComplex k -> Just $ printFKind (FTComplexWrapper k)+  FSTLogical k -> Just $ printFKind k+  FSTString  l -> Just $ fromIntegral l+  FSTCustom  t -> Nothing++prettyKinded :: FKind a => a -> String -> String prettyKinded k name = name<>"("<>show (printFKind k)<>")"

@@ -1,63 +1,14 @@ 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+import Data.Word ( Word8 ) --- | 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+-- | The internal type used to pass type kinds around.+type FKindLit = Word8  -- | 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+class FKind a where+    -- | Serialize the kind tag to the shared kind representation.+    printFKind :: a -> FKindLit --- | 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+    -- | Parse a kind tag from the shared kind representation.+    parseFKind :: FKindLit -> Maybe a

@@ -8,6 +8,8 @@ alternatively, could enforce usage of this -} +{-# LANGUAGE DerivingVia #-}+ module Language.Fortran.Repr.Type.Scalar.Complex where  import Language.Fortran.Repr.Type.Scalar.Common@@ -15,17 +17,17 @@  import GHC.Generics ( Generic ) import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )  newtype FTComplexWrapper = FTComplexWrapper { unFTComplexWrapper :: FTReal }-    deriving stock (Generic, Data, Show, Eq, Ord)+    deriving stock (Show, Generic, Data)+    deriving (Enum, Eq, Ord) via FTReal+    deriving anyclass (Binary, Out) -instance FKinded FTComplexWrapper where-    type FKindOf ('FTComplexWrapper 'FTReal4) = 8-    type FKindOf ('FTComplexWrapper 'FTReal8) = 16-    type FKindDefault = 'FTComplexWrapper 'FTReal4+instance FKind FTComplexWrapper where     parseFKind = \case 8  -> Just $ FTComplexWrapper FTReal4                        16 -> Just $ FTComplexWrapper FTReal8                        _ -> Nothing-    printFKind = \case-      FTComplexWrapper FTReal4 -> 8-      FTComplexWrapper FTReal8 -> 16+    printFKind = \case FTComplexWrapper FTReal4 -> 8+                       FTComplexWrapper FTReal8 -> 16

@@ -1,5 +1,4 @@-{-# LANGUAGE TemplateHaskell, StandaloneKindSignatures, UndecidableInstances #-}-{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE StandaloneKindSignatures #-}  module Language.Fortran.Repr.Type.Scalar.Int where @@ -7,36 +6,35 @@  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 Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) -import GHC.TypeNats+-- | The Fortran integer type.+data FTInt+  = FTInt1  -- ^ @INTEGER(1)@+  | FTInt2  -- ^ @INTEGER(2)@+  | FTInt4  -- ^ @INTEGER(4)@+  | FTInt8  -- ^ @INTEGER(8)@+  | FTInt16 -- ^ @INTEGER(16)@+    deriving stock (Show, Generic, Data, Enum, Eq, Ord)+    deriving anyclass (Binary, Out) -$(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+instance FKind FTInt where+    parseFKind = \case 1  -> Just FTInt1+                       2  -> Just FTInt2+                       4  -> Just FTInt4+                       8  -> Just FTInt8+                       16 -> Just FTInt16+                       _  -> Nothing+    printFKind = \case FTInt1  -> 1+                       FTInt2  -> 2+                       FTInt4  -> 4+                       FTInt8  -> 8+                       FTInt16 -> 16 --- | 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@@ -45,43 +43,3 @@     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)

@@ -1,43 +1,22 @@-{-# 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+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) --- | 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+data FTReal+  = FTReal4+  | FTReal8+    deriving stock (Show, Generic, Data, Enum, Eq, Ord)+    deriving anyclass (Binary, Out) -instance FKinded FTReal where-    type FKindOf 'FTReal4 = 4-    type FKindOf 'FTReal8 = 8-    type FKindDefault = 'FTReal4+instance FKind FTReal where     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+    printFKind = \case FTReal4 -> 4+                       FTReal8 -> 8

@@ -1,18 +1,13 @@-{-# 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+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.Orphans() --- $(singletons [d| -- | The length of a CHARACTER value. -- -- IanH provides a great reference on StackOverflow:@@ -32,11 +27,8 @@   -- ^ @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+    deriving stock (Show, Generic, Data, Eq, Ord)+    deriving anyclass (Binary, Out)  prettyCharLen :: Natural -> String prettyCharLen l = "LEN="<>show l

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

@@ -1,106 +0,0 @@-{- | 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)

@@ -1,14 +1,20 @@+{-# LANGUAGE DerivingVia #-}+ 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+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) +-- | A Fortran value (scalar only currently).+data FValue = MkFScalarValue FScalarValue+    deriving stock (Show, Generic, Data, Eq)+    deriving anyclass (Binary, Out)+ fValueType :: FValue -> FType fValueType = \case   MkFScalarValue a -> MkFScalarType $ fScalarValueType a-  MkFArrayValue  a -> MkFArrayType  $ fArrayValueType  a

@@ -1,8 +1,22 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+ -- | Common definitions for Fortran scalar representations. module Language.Fortran.Repr.Value.Scalar.Common where +import Language.Fortran.Repr.Type.Scalar.Common+ import Data.Singletons +import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) )+import Data.Binary+import Data.Data ( Data, Typeable )++import Data.Kind+ {- | 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@@ -12,9 +26,79 @@ 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).++Note that many type classes usually derived generically (e.g.+'Data.Binary.Binary') instances should be manually derived on this wrapper type.+TODO give a better explanation why? -}-data SomeFKinded k ft = forall (fk :: k). (SingKind k, SingI fk) => SomeFKinded (ft fk)+data SomeFKinded k ft where+    SomeFKinded+        :: forall {k} ft (fk :: k)+        .  (SingKind k, SingI fk, Data (ft fk))+        => ft fk+        -> SomeFKinded k ft +deriving stock instance+  ( SingKind k+  , forall (fk :: k). SingI fk+  , forall (fk :: k). Data (ft fk)+  , Typeable ft+  , Typeable k+  ) => Data (SomeFKinded k ft)+--instance (Typeable k, Typeable ft) => Data (SomeFKinded k ft) where++-- | GHC can derive stock 'Show' instances given some @QuantifiedConstraints@+--   guarantees (wow!).+deriving stock instance (forall fk. Show (ft fk)) => Show (SomeFKinded k ft)++-- | Derive 'Out' instances via 'Show'.+deriving via OutShowly (SomeFKinded k ft) instance (forall fk. Show (ft fk)) => Out (SomeFKinded k ft)++-- | For any Fortran type @ft@ kinded with @k@, we may derive a 'Binary'+--   instance by leveraging the kind tag's instance @'Binary' ('Demote' k)@ and+--   the kinded value's instance @'Binary' (ft k)@. (We also have to ferry some+--   singletons instances through.)+--+-- WARNING: This instance is only sound for types where each kind tag value is+-- used once at most (meaning if you know the fkind, you know the constructor).+--+-- Note that the 'Data.Binary.Get' instance works by parsing a kind tag,+-- promoting it to a singleton, then gleaning type information and using that to+-- parse the inner kinded value. Dependent types!+-- TODO if we pack a Data context into SomeFKinded, get can't recover it!!+instance+  ( Binary (Demote k)+  , SingKind k+  , forall (fk :: k). SingI fk => Binary (ft fk)+  , forall (fk :: k). Data (ft fk)+  ) => Binary (SomeFKinded k ft) where+    put someV@(SomeFKinded v) = do+        put $ someFKindedKind someV+        put v+    get = get @(Demote k) >>= \case -- parse fkind tag+      kindTag ->+        withSomeSing kindTag f+      where+        f :: forall (fk :: k). Sing fk -> Get (SomeFKinded k ft)+        f kind = do+            withSingI @fk kind $ do+                v <- get @(ft fk)+                pure $ undefined -- SomeFKinded @k @ft v+ -- | Recover some @TYPE(x)@'s kind (the @x@). someFKindedKind :: SomeFKinded k ft -> Demote k someFKindedKind (SomeFKinded (_ :: ft fk)) = demote @fk++---++-- | A kinded Fortran value.+class FKinded a where+    -- | The Haskell type used to record this Fortran type's kind.+    type FKindedT a++    -- | For every Fortran kind of this Fortran type @a@, the underlying+    --   representation @b@ has the given constraints.+    type FKindedC a b :: Constraint++    -- | Obtain the kind of a Fortran value.+    fKind :: a -> FKindedT a

@@ -3,30 +3,45 @@ A Fortran COMPLEX is simply two REALs of the same kind. -} +{-# LANGUAGE DerivingVia #-}+ module Language.Fortran.Repr.Value.Scalar.Complex where  import Language.Fortran.Repr.Value.Scalar.Common import Language.Fortran.Repr.Type.Scalar.Real+import Language.Fortran.Repr.Value.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+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) -type SomeFComplex = SomeFKinded FTReal FComplex-deriving stock instance Show SomeFComplex-instance Eq SomeFComplex where-    (SomeFKinded l) == (SomeFKinded r) = fComplexBOp (==) (&&) l r+data FComplex+  = FComplex8  {- ^ @COMPLEX(8)@  -} Float  Float+  | FComplex16 {- ^ @COMPLEX(16)@ -} Double Double+    deriving stock (Show, Generic, Data)+    deriving anyclass (Binary, Out) +instance FKinded FComplex where+    type FKindedT FComplex = FTReal+    type FKindedC FComplex a = RealFloat a+    fKind = \case+      FComplex8{}  -> FTReal4+      FComplex16{} -> FTReal8++instance Eq FComplex where (==) = fComplexBOp (==) (&&)++fComplexFromReal :: FReal -> FComplex+fComplexFromReal = \case FReal4 x -> FComplex8  x 0.0+                         FReal8 x -> FComplex16 x 0.0+ fComplexBOp'     :: (Float  -> Float  -> a)     -> (a -> a -> r)     -> (Double -> Double -> b)     -> (b -> b -> r)-    -> FComplex kl -> FComplex kr -> r+    -> FComplex -> FComplex -> 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)@@ -40,8 +55,19 @@             ri' = float2Double ri         in  k16g (k16f lr rr') (k16f li ri') +fComplexBOpInplace'+    :: (Float  -> Float  -> Float)+    -> (Double -> Double -> Double)+    -> FComplex -> FComplex -> FComplex+fComplexBOpInplace' k8f k16f = fComplexBOp' k8f FComplex8 k16f FComplex16+ fComplexBOp-    :: (forall a. RealFloat a => a -> a -> b)+    :: (forall a. FKindedC FComplex a => a -> a -> b)     -> (b -> b -> r)-    -> FComplex kl -> FComplex kr -> r+    -> FComplex -> FComplex -> r fComplexBOp f g = fComplexBOp' f g f g++fComplexBOpInplace+    :: (forall a. FKindedC FComplex a => a -> a -> a)+    -> FComplex -> FComplex -> FComplex+fComplexBOpInplace f = fComplexBOpInplace' f f

@@ -13,11 +13,14 @@ 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 +import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+ type FIntMRep :: FTInt -> Type type family FIntMRep k = r | r -> k where     FIntMRep 'FTInt1 = Int8@@ -26,7 +29,9 @@     FIntMRep 'FTInt8 = Int64  newtype FIntI (k :: FTInt) = FIntI Integer-    deriving (Show, Eq, Ord) via Integer+    deriving stock (Show, Generic, Data)+    deriving (Eq, Ord) via Integer+    deriving anyclass (Binary, Out)  fIntICheckBounds     :: forall k rep. (rep ~ FIntMRep k, Bounded rep, Integral rep)@@ -38,31 +43,18 @@          then Just "TODO too small"          else Nothing -type SomeFIntI = SomeFKinded FTInt FIntI+data SomeFIntI = forall fk. SomeFIntI (FIntI fk) deriving stock instance Show SomeFIntI instance Eq SomeFIntI where-    (SomeFKinded (FIntI l)) == (SomeFKinded (FIntI r)) = l == r+    (SomeFIntI (FIntI l)) == (SomeFIntI (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+someFIntIBOpWrap f (SomeFIntI (FIntI li :: FIntI lfk)) (SomeFIntI (FIntI ri :: FIntI rfk)) =+    SomeFIntI $ FIntI @(FTIntCombine lfk rfk) $ f li ri  {- fIntIBOpWrap

@@ -7,119 +7,64 @@ 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+module Language.Fortran.Repr.Value.Scalar.Int.Machine 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+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.Orphans() --- | 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)+-- | A Fortran integer value, type @INTEGER(k)@.+data FInt+  = FInt1 {- ^ @INTEGER(1)@ -} Int8+  | FInt2 {- ^ @INTEGER(2)@ -} Int16+  | FInt4 {- ^ @INTEGER(4)@ -} Int32+  | FInt8 {- ^ @INTEGER(8)@ -} Int64+    deriving stock (Show, Generic, Data)+    deriving anyclass (Binary, Out) -type IsFInt a = (Integral a, Bits a)+instance FKinded FInt where+    type FKindedT FInt = FTInt+    type FKindedC FInt a = (Integral a, Bits a)+    fKind = \case+      FInt1{} -> FTInt1+      FInt2{} -> FTInt2+      FInt4{} -> FTInt4+      FInt8{} -> FTInt8 -type SomeFInt = SomeFKinded FTInt FInt-deriving stock instance Show SomeFInt-instance Eq SomeFInt where-    (SomeFKinded l) == (SomeFKinded r) = fIntBOp (==) l r+instance Eq FInt where (==) = fIntBOp (==) --- | 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+withFInt :: Num a => FInt -> a+withFInt = fIntUOp fromIntegral --- | Run an operation over some 'FInt', with a concrete function for each kind.+-- Pattern matches are ordered to match more common ops earlier. 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+    -> FInt -> r+fIntUOp' k1f k2f k4f k8f = \case+  FInt4 i32 -> k4f i32+  FInt8 i64 -> k8f i64+  FInt2 i16 -> k2f i16+  FInt1 i8  -> k1f i8 --- | 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+fIntBOp'+    :: (Int8  -> Int8  -> r)+    -> (Int16 -> Int16 -> r)+    -> (Int32 -> Int32 -> r)+    -> (Int64 -> Int64 -> r)+    -> FInt -> FInt -> r+fIntBOp' k1f k2f k4f k8f il ir = case (il, ir) of   (FInt4 l32, FInt4 r32) -> k4f l32 r32   (FInt8 l64, FInt8 r64) -> k8f l64 r64 @@ -144,55 +89,43 @@    (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+fIntUOpInplace'+    :: (Int8  -> Int8)+    -> (Int16 -> Int16)+    -> (Int32 -> Int32)+    -> (Int64 -> Int64)+    -> FInt -> FInt+fIntUOpInplace' k1f k2f k4f k8f =+    fIntUOp' (FInt1 . k1f) (FInt2 . k2f) (FInt4 . k4f) (FInt8 . k8f)  fIntBOpInplace'     :: (Int8  -> Int8  -> Int8)     -> (Int16 -> Int16 -> Int16)     -> (Int32 -> Int32 -> Int32)     -> (Int64 -> Int64 -> Int64)-    -> FInt kl -> FInt kr -> FInt (FTIntCombine kl kr)+    -> FInt -> FInt -> FInt 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+    fIntBOp' (f FInt1 k1f) (f FInt2 k2f) (f FInt4 k4f) (f FInt8 k8f)+  where f cstr bop l r = cstr $ bop 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+fIntUOp :: (forall a. FKindedC FInt a => a -> r) -> FInt -> r+fIntUOp f = fIntUOp' 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+fIntUOpInplace :: (forall a. FKindedC FInt a => a -> a) -> FInt -> FInt+fIntUOpInplace f = fIntUOpInplace' f f f f -fIntMax :: forall (k :: FTInt). KnownNat (FTIntMax k) => Int64-fIntMax = fromIntegral $ natVal'' @(FTIntMax k)+fIntBOp :: (forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r+fIntBOp f = fIntBOp' f f f f -fIntMin :: forall (k :: FTInt). KnownNat (FTIntMin k) => Int64-fIntMin = fromIntegral $ natVal'' @(FTIntMin k)+fIntBOpInplace :: (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt+fIntBOpInplace f = fIntBOpInplace' f f f f --- 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)+{-++-- TODO improve: always return answer, plus a flag indicating if there was an+-- error, plus this should be in eval instead and this should be simpler+-- (shouldn't be wrapping in Either)+fIntCoerceChecked :: FTInt -> FInt -> Either String FInt fIntCoerceChecked ty = fIntUOp $ \n ->     if fromIntegral n > fIntMax @kout then         Left "too large for new size"@@ -200,16 +133,10 @@         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"+          FTInt1  -> Right $ FInt1 $ fromIntegral n+          FTInt2  -> Right $ FInt2 $ fromIntegral n+          FTInt4  -> Right $ FInt4 $ fromIntegral n+          FTInt8  -> Right $ FInt8 $ fromIntegral n+          FTInt16 -> 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+-}

@@ -11,7 +11,7 @@ import Language.Fortran.Repr.Value.Scalar.Int.Machine  -- | Retrieve the boolean value stored by a @LOGICAL(x)@.-fLogicalToBool :: FInt k -> Bool+fLogicalToBool :: FInt -> Bool fLogicalToBool = fIntUOp $ consumeFLogicalNumeric True False  -- | Convert a bool to its Fortran machine representation in any numeric type.@@ -23,5 +23,5 @@ consumeFLogicalNumeric whenTrue whenFalse bi =     if bi == 1 then whenTrue else whenFalse -fLogicalNot :: FInt k -> FInt k+fLogicalNot :: FInt -> FInt fLogicalNot = fIntUOpInplace (consumeFLogicalNumeric 0 1)

@@ -11,9 +11,16 @@ 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 Data.Text ( Text )+import qualified Data.Text as Text+ import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.Orphans()  {- $type-coercion-implementation @@ -33,18 +40,19 @@  -- | A Fortran scalar value. data FScalarValue-  = FSVInt     SomeFInt-  | FSVReal    SomeFReal-  | FSVComplex SomeFComplex-  | FSVLogical SomeFInt-  | FSVString  SomeFString-    deriving stock (Generic, Show, Eq)+  = FSVInt     FInt+  | FSVReal    FReal+  | FSVComplex FComplex+  | FSVLogical FInt+  | FSVString  Text+    deriving stock (Show, Generic, Data, Eq)+    deriving anyclass (Binary, Out)  -- | 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+  FSVInt     a -> FSTInt     $ fKind a+  FSVReal    a -> FSTReal    $ fKind a+  FSVComplex a -> FSTComplex $ fKind a+  FSVLogical a -> FSTLogical $ fKind a+  FSVString  a -> FSTString  $ fromIntegral $ Text.length a

@@ -1,106 +1,76 @@-module Language.Fortran.Repr.Value.Scalar.Real-  ( FReal(..)-  , SomeFReal--  , fRealUOp-  , fRealUOp'-  , fRealUOpInplace-  , fRealUOpInplace'-  , fRealUOpInternal--  , fRealBOp-  , fRealBOp'-  , fRealBOpInplace-  , fRealBOpInplace'-  , fRealBOpInternal-  ) where+module Language.Fortran.Repr.Value.Scalar.Real 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)+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Binary ( Binary )+import Text.PrettyPrint.GenericPretty ( Out ) -fRealUOpInternal-    :: (Float  -> ft 'FTReal4)-    -> (Double -> ft 'FTReal8)-    -> FReal k -> ft k-fRealUOpInternal k4f k8f = \case-  FReal4 fl -> k4f fl-  FReal8 db -> k8f db+data FReal+  = FReal4 {- ^ @REAL(4)@ -} Float+  | FReal8 {- ^ @REAL(8)@ -} Double+    deriving stock (Show, Generic, Data)+    deriving anyclass (Binary, Out) --- | Run an operation over some 'FReal', with a concrete function for each kind.+instance FKinded FReal where+    type FKindedT FReal = FTReal+    type FKindedC FReal a = RealFloat a+    fKind = \case+      FReal4{} -> FTReal4+      FReal8{} -> FTReal8++instance Eq FReal where (==) = fRealBOp (==)+ fRealUOp'     :: (Float  -> r)     -> (Double -> r)-    -> FReal k -> r-fRealUOp' k4f k8f = getConst . fRealUOpInternal (Const . k4f) (Const . k8f)+    -> FReal -> r+fRealUOp' k4f k8f = \case+  FReal4 fl -> k4f fl+  FReal8 db -> k8f db --- | Run an operation over some 'FReal'.-fRealUOp-    :: (forall a. RealFloat a => a -> r)-    -> FReal k -> r-fRealUOp f = fRealUOp' f f+fRealBOp'+    :: (Float  -> Float  -> r)+    -> (Double -> Double -> r)+    -> FReal -> FReal -> r+fRealBOp' 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) --- | 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)+    -> FReal -> FReal+fRealUOpInplace' k4f k8f = fRealUOp' (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+fRealBOpInplace'+    :: (Float  -> Float  -> Float)+    -> (Double -> Double -> Double)+    -> FReal -> FReal -> FReal+fRealBOpInplace' k4f k8f = fRealBOp' (f FReal4 k4f) (f FReal8 k8f)+  where f cstr bop l r = cstr $ bop l r --- | 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)+fRealUOp+    :: (forall a. FKindedC FReal a => a -> r)+    -> FReal -> r+fRealUOp f = fRealUOp' f f -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'+fRealUOpInplace+    :: (forall a. FKindedC FReal a => a -> a)+    -> FReal -> FReal+fRealUOpInplace f = fRealUOpInplace' f f  fRealBOp-    :: (forall a. RealFloat a => a -> a -> r)-    -> FReal kl -> FReal kr -> r+    :: (forall a. FKindedC FReal a => a -> a -> r)+    -> FReal -> FReal -> 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)+    :: (forall a. FKindedC FReal a => a -> a -> a)+    -> FReal -> FReal -> FReal 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

@@ -1,3 +1,6 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+ {- | Fortran CHAR value representation.  Currently only CHARs of known length.@@ -13,13 +16,45 @@ import Data.Proxy import Unsafe.Coerce +import Text.PrettyPrint.GenericPretty ( Out )+import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) )+import Data.Binary+import Data.Data++import Data.Singletons+import GHC.TypeLits.Singletons+ -- 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+deriving stock instance KnownNat l => Data (FString l) +{-+instance Data (FString l) where+    --gunfold k z c = k (z (\x -> case someFString x of SomeFString y -> y))+    gunfold k z c = k (z (FString @l))+-}++eqFString :: FString l -> FString r -> Bool+eqFString (FString l) (FString r) = l == r++-- | This is a painful instance to define. We cheat by leveraging the instance+--   of the length-hiding type 'SomeFString', then asserting length. It's CPU+--   and memory inefficient and has backwards dependencies, but is comfortably+--   safe.+instance KnownNat l => Binary (FString l) where+    put t = put (SomeFString t)+    get =+        get @SomeFString >>= \case+          SomeFString (FString t) ->+            case fString @l t of+              Just t' -> pure t'+              Nothing -> fail "FString had incorrect length"++-- | Attempt to a 'Text' into an 'FString' of the given length. fString :: forall l. KnownNat l => Text -> Maybe (FString l) fString s =     if   Text.length s == fromIntegral (natVal'' @l)@@ -31,13 +66,34 @@  data SomeFString = forall (l :: NaturalK). KnownNat l => SomeFString (FString l) deriving stock instance Show SomeFString+deriving via (OutShowly SomeFString) instance Out SomeFString+ instance Eq SomeFString where-    (SomeFString (FString sl)) == (SomeFString (FString sr)) = sl == sr+    (SomeFString l) == (SomeFString r) = l `eqFString` r +-- TODO impossible??+instance Data SomeFString where++{-+dataSomeFStringT = mkDataType "TODO" [dataSomeFStringC1]+dataSomeFStringC1 = mkConstr dataSomeFStringT "SomeFString" [] Prefix+instance Data SomeFString where+    dataTypeOf _ = dataSomeFStringT+    toConstr = \case+      SomeFString{} -> dataSomeFStringC1+    --gunfold k z c = k (z SomeFString)+    gunfold k z c = k (z (\(FString fstr :: FString l) -> SomeFString @l (FString fstr)))+-}++instance Binary SomeFString where+    put (SomeFString (FString t)) = put t+    get = someFString <$> get @Text++-- | Lift a 'Text' into 'SomeFString'. someFString :: Text -> SomeFString-someFString s =-    case someNatVal (fromIntegral (Text.length s)) of-      SomeNat (_ :: Proxy n) -> SomeFString $ FString @n s+someFString t =+    case someNatVal (fromIntegral (Text.length t)) of+      SomeNat (_ :: Proxy l) -> SomeFString $ FString @l t  someFStringLen :: SomeFString -> Natural someFStringLen (SomeFString s) = fStringLen s

@@ -1,5 +1,6 @@ module Language.Fortran.Util.Files   ( flexReadFile+  , runCPP   , getDirContents   , rGetDirContents   ) where@@ -10,8 +11,10 @@ import           System.Directory (listDirectory, canonicalizePath,                                    doesDirectoryExist, getDirectoryContents) import           System.FilePath  ((</>))-import           Data.List        ((\\))-+import           System.IO.Temp   (withSystemTempDirectory)+import           System.Process   (callProcess)+import           Data.List        ((\\), foldl')+import           Data.Char        (isNumber) -- | Obtain a UTF-8 safe 'B.ByteString' representation of a file's contents. -- -- Invalid UTF-8 is replaced with the space character.@@ -39,3 +42,29 @@               x' <- go (path : seen) path               return $ map (\ y -> x ++ "/" ++ y) x'             else return [x]++-- | Run the C Pre Processor over the file before reading into a bytestring+runCPP :: Maybe String -> FilePath -> IO B.ByteString+runCPP Nothing path          = flexReadFile path -- Nothing = do not run CPP+runCPP (Just cppOpts) path   = do+  -- Fold over the lines, skipping CPP pragmas and inserting blank+  -- lines as needed to make the line numbers match up for the current+  -- file. CPP pragmas for other files are just ignored.+  let processCPPLine :: ([B.ByteString], Int) -> B.ByteString -> ([B.ByteString], Int)+      processCPPLine (revLs, curLineNo) curLine+        | B.null curLine || B.head curLine /= '#' = (curLine:revLs, curLineNo + 1)+        | linePath /= path                        = (revLs, curLineNo)+        | newLineNo <= curLineNo                  = (revLs, curLineNo)+        | otherwise                               = (replicate (newLineNo - curLineNo) B.empty ++ revLs,+                                                     newLineNo)+          where+            newLineNo = read . B.unpack . B.takeWhile isNumber . B.drop 2 $ curLine+            linePath = B.unpack . B.takeWhile (/='"') . B.drop 1 . B.dropWhile (/='"') $ curLine++  withSystemTempDirectory "fortran-src" $ \ tmpdir -> do+    let outfile = tmpdir </> "cpp.out"+    callProcess "cpp" $ words cppOpts ++ ["-CC", "-nostdinc", "-o", outfile, path]+    contents <- flexReadFile outfile+    let ls = B.lines contents+    let ls' = reverse . fst $ foldl' processCPPLine ([], 1) ls+    return $ B.unlines ls'

@@ -121,7 +121,7 @@                        , mfTypeEnv     :: FAT.TypeEnv                        , mfParamVarMap :: ParamVarMap                        , mfOtherData   :: M.Map String LB.ByteString }-  deriving (Eq, Ord, Show, Data, Typeable, Generic)+  deriving (Eq, Show, Data, Typeable, Generic)  instance Binary ModFile 

@@ -20,9 +20,9 @@ -- The constructor ordering is important, since it's used for the Ord instance -- (which is used extensively for pretty printing). data FortranVersion = Fortran66-                    | Fortran77-                    | Fortran77Extended-                    | Fortran77Legacy+                    | Fortran77         -- ^ fairly close to FORTRAN 77 standard+                    | Fortran77Extended -- ^ F77 with some extensions+                    | Fortran77Legacy   -- ^ F77 with most extensions                     | Fortran90                     | Fortran95                     | Fortran2003@@ -60,10 +60,10 @@ -- Defaults to Fortran 90 if suffix is unrecognized. deduceFortranVersion :: FilePath -> FortranVersion deduceFortranVersion path-  | isExtensionOf ".f"      = Fortran77Extended-  | isExtensionOf ".for"    = Fortran77-  | isExtensionOf ".fpp"    = Fortran77-  | isExtensionOf ".ftn"    = Fortran77+  | isExtensionOf ".f"      = Fortran77Legacy+  | isExtensionOf ".for"    = Fortran77Legacy+  | isExtensionOf ".fpp"    = Fortran77Legacy+  | isExtensionOf ".ftn"    = Fortran77Legacy   | isExtensionOf ".f90"    = Fortran90   | isExtensionOf ".f95"    = Fortran95   | isExtensionOf ".f03"    = Fortran2003

@@ -0,0 +1,21 @@+{-# LANGUAGE DerivingVia #-}+-- TODO orphans pragma++module Text.PrettyPrint.GenericPretty.Orphans where++import Text.PrettyPrint.GenericPretty+import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) )++import Data.Text ( Text )+import qualified Data.Text as Text+import Data.Int+import Numeric.Natural++-- | Not particularly efficient (but neither is GenericPretty).+deriving via OutShowly Text instance Out Text++deriving via OutShowly Int8  instance Out Int8+deriving via OutShowly Int16 instance Out Int16+deriving via OutShowly Int32 instance Out Int32+deriving via OutShowly Int64 instance Out Int64+deriving via OutShowly Natural instance Out Natural

@@ -0,0 +1,31 @@+{- | Low-boilerplate 'Text.PrettyPrint.GenericPretty.Out' instances for+    'Show'ables using @DerivingVia@.++Useful for integrating types that don't work nicely with 'Generic' with+@GenericPretty@. (Really, there should be a class like+'Text.PrettyPrint.GenericPretty.Out' directly in @pretty@, but alas.)++Use as follows:++data EeGadts a where+    C1 :: EeGadts Bool+    C2 :: EeGadts String+deriving stock instance Show (EeGadts a)+deriving via OutShowly (EeGadts a) instance Out (EeGadts a)+-}++{-# LANGUAGE DerivingVia #-}++module Text.PrettyPrint.GenericPretty.ViaShow+  ( module Text.PrettyPrint.GenericPretty.ViaShow+  , Text.PrettyPrint.GenericPretty.Out+  ) where++import Text.PrettyPrint.GenericPretty ( Out(..) )+import qualified Text.PrettyPrint++newtype OutShowly a = OutShowly { unOutShowly :: a }++instance Show a => Out (OutShowly a) where+    doc (OutShowly a) = Text.PrettyPrint.text $ show a+    docPrec n (OutShowly a) = Text.PrettyPrint.text $ showsPrec n a ""

@@ -2,8 +2,6 @@  import Test.Hspec import TestUtil-import Test.Hspec.QuickCheck-import Test.QuickCheck (Positive(..))  import Language.Fortran.AST import Language.Fortran.Analysis@@ -251,11 +249,6 @@     describe "other" $       it "dominators on disconnected graph" $         dominators (BBGr (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)])) [0,5] [3,9]) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])]--    describe "Constants" $ do-      prop "constant folding evaluates exponentation (positive exponent)" $-        let constExpoExpr b e = ConstBinary Exponentiation (ConstInt b) (ConstInt e)-         in \(base, Positive expo) -> constantFolding (constExpoExpr base expo) `shouldBe` ConstInt (base ^ expo)  -------------------------------------------------- -- Label-finding helper functions to help write tests that are

@@ -8,7 +8,7 @@ import Language.Fortran.Parser ( initParseStateFree ) import Language.Fortran.AST.Literal.Real import Language.Fortran.Version-import Language.Fortran.Util.Position (SrcSpan)+import Language.Fortran.Util.Position (SrcSpan(..), initSrcSpan, initPosition, posPragmaOffset, getSpan)  import qualified Data.ByteString.Char8 as B @@ -283,6 +283,45 @@         it "Continuation with inline comment" $           shouldBe' (collectF90 "i = &  ! hi \n  42") $                     pseudoAssign $ flip TIntegerLiteral "42"++        -- posPragmaOffset is the difference between the given line and the current next line.+        let testPos = initPosition { posPragmaOffset = Just (40 - (2 + 1), "file.f") }+            testSS = SrcSpan testPos testPos+            lpToks = fmap ($initSrcSpan) [ flip TId "i", TOpAssign] +++                     fmap ($testSS) [flip TIntegerLiteral "42", TEOF ]+            ppoOf  = posPragmaOffset . ssFrom . getSpan++        it "Continuation with line pragma" $+          shouldBe (ppoOf <$> collectF90 "i = &\n #line 40 \"file.f\"\n  42") $+                   ppoOf <$> lpToks++        it "Continuation with line pragma (tokens)" $+          shouldBe' (collectF90 "i = &\n #line 40 \"file.f\"\n  42")+                    lpToks++        it "Continuation with line pragma (CPP style)" $+          shouldBe (ppoOf <$> collectF90 "i = &\n # 40 \"file.f\"\n  42") $+                   ppoOf <$> lpToks++      describe "Line pragma directives" $ do+        -- posPragmaOffset is the difference between the given line and the current next line.+        let testPos = initPosition { posPragmaOffset = Just (40 - (2 + 1), "file.f") }+            testSS = SrcSpan testPos testPos+            lpToks = fmap ($initSrcSpan) [ flip TId "i", TOpAssign, flip TIntegerLiteral "42", TNewline ] +++                     fmap ($testSS) [flip TId "j", TOpAssign, flip TIntegerLiteral "42", TEOF ]+            ppoOf  = posPragmaOffset . ssFrom . getSpan++        it "Line pragma" $+          shouldBe (ppoOf <$> collectF90 "i = 42\n#line 40 \"file.f\"\n j = 42") $+                   ppoOf <$> lpToks++        it "Line pragma (tokens)" $+          shouldBe' (collectF90 "i = 42\n#line 40 \"file.f\"\n j = 42")+                    lpToks++        it "Line pragma (CPP style)" $+          shouldBe (ppoOf <$> collectF90 "i = 42\n# 40 \"file.f\"\n j = 42") $+                   ppoOf <$> lpToks        describe "Comment" $ do         it "Full line comment" $

@@ -548,6 +548,19 @@                   <> "&\n     &"                   <> "illy_variable_name = 1"         reformatMixedFormInsertContinuations input `shouldBe` expect+      it "correctly handles 72 character long statements" $ do+        let input  = "      integer*4 :: x, y, z\n"+                  <> "        x = +(((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x)))"+            expect = "      integer*4 :: x, y, z\n"+                  <> "        x = +(((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x)))"+        reformatMixedFormInsertContinuations input `shouldBe` expect+      it "correctly handles 73 character long statements" $ do+        let input  = "      integer*4 :: x, y, z\n"+                  <> "        x = + (((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x)))"+            expect = "      integer*4 :: x, y, z\n"+                  <> "        x = + (((y - (z - 48)) * ((z + 62) - z)) + (((- z) * x) / (- x))&\n"+                  <> "     &)"+        reformatMixedFormInsertContinuations input `shouldBe` expect        it "does not continuate a long mixed-form comment line" $ do         let input  = "      ! a very long, long comment that ends up"

@@ -0,0 +1,43 @@+module Language.Fortran.Repr.EvalSpec where++import Test.Hspec+import Test.Hspec.QuickCheck ( prop )+import Test.QuickCheck ( NonNegative(..) )++import TestUtil ( u )++import Language.Fortran.AST+import Language.Fortran.Repr+import Language.Fortran.Repr.Eval.Value++import Data.Int++spec :: Spec+spec =+  describe "exponentiation" $+    prop "integer exponentation (+ve exponent) (INTEGER(4))" $+      \base (NonNegative (expo :: Int32)) ->+        let expr = expBinary Exponentiation (expValInt base) (expValInt expo)+         in shouldEvalTo (FSVInt (FInt4 (base^expo))) (evalExpr expr)++shouldEvalTo :: FScalarValue -> FEvalValuePure FValue -> Expectation+shouldEvalTo checkVal prog =+    case runEvalFValuePure mempty prog of+      Right (a, _msgs) ->+        case a of+          MkFScalarValue a' -> a' `shouldBe` checkVal+          -- _ -> expectationFailure "not a scalar"+      Left e -> expectationFailure (show e)++expBinary :: BinaryOp -> Expression () -> Expression () -> Expression ()+expBinary = ExpBinary () u++expValue :: Value () -> Expression ()+expValue = ExpValue () u++-- | default kind. take integral-like over String because nicer to write :)+valInteger :: (Integral a, Show a) => a -> Value ()+valInteger i = ValInteger (show i) Nothing++expValInt :: (Integral a, Show a) => a -> Expression ()+expValInt = expValue . valInteger