{-
   Copyright 2018, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
-}

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}

module Camfort.Specification.DerivedDataType
       ( infer, refactor, check, synth, compile
       , DerivedDataTypeReport(..), successful )
where

import           Camfort.Analysis
import           Camfort.Analysis.Annotations (onPrev, buildCommentText, A, Annotation(..))
import           Camfort.Analysis.CommentAnnotator (annotateComments, ASTEmbeddable(..), Linkable(..))
import           Camfort.Analysis.ModFile
import           Camfort.Helpers.Syntax (afterAligned, toCol0, deleteLine)
import           Camfort.Specification.DerivedDataType.Parser (ddtParser, DDTStatement(..))
import           Control.Applicative
import           Control.Arrow (first, second, (&&&))
import           Control.DeepSeq
import           Control.Monad
import           Control.Monad.RWS.Strict
import           Control.Monad.Writer.Strict
import           Data.Binary (Binary, decodeOrFail, encode)
import           Data.Data
import           Data.Function (on)
import           Data.Generics.Uniplate.Operations hiding (rewrite)
import qualified Data.IntMap.Strict as IM
import           Data.List (sort, foldl', groupBy)
import qualified Data.List as List
import qualified Data.Map.Strict as M
import           Data.Maybe (mapMaybe, fromMaybe, fromJust, isJust)
import           Data.Monoid ((<>))
import qualified Data.Semigroup as SG
import qualified Data.Set as S
import qualified Data.Strict.Either as SE
import           Data.Text (Text, unlines, intercalate, pack)
import qualified Data.Text.Lazy.Builder as Builder
import           GHC.Generics (Generic)
import qualified Language.Fortran.AST as F
import qualified Language.Fortran.Analysis as FA
import qualified Language.Fortran.Analysis.BBlocks as FAB
import qualified Language.Fortran.Analysis.DataFlow as FAD
import qualified Language.Fortran.Analysis.Types as FAT
import           Language.Fortran.Util.ModFile
import qualified Language.Fortran.Util.Position as FU
import           Prelude hiding (unlines, minBound, maxBound)

ddtShort :: String
ddtShort :: String
ddtShort = String
"ddt"

--------------------------------------------------
-- Linking DDT specifications with associated AST-blocks.

-- | Annotation used for derived-datatype info.
data DDTAnnotation = DDTAnnotation {
    DDTAnnotation -> A
prevAnnotation :: A,
    DDTAnnotation -> Maybe DDTStatement
ddtSpec        :: Maybe DDTStatement,      -- ^ parsed spec on comments, if any
    DDTAnnotation -> Maybe (Block DA)
ddtBlock       :: Maybe (F.Block DA)       -- ^ linked variable declaration, if any
  } deriving (Typeable DDTAnnotation
DataType
Constr
Typeable DDTAnnotation
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> DDTAnnotation -> c DDTAnnotation)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DDTAnnotation)
-> (DDTAnnotation -> Constr)
-> (DDTAnnotation -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DDTAnnotation))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DDTAnnotation))
-> ((forall b. Data b => b -> b) -> DDTAnnotation -> DDTAnnotation)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r)
-> (forall u. (forall d. Data d => d -> u) -> DDTAnnotation -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DDTAnnotation -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation)
-> Data DDTAnnotation
DDTAnnotation -> DataType
DDTAnnotation -> Constr
(forall b. Data b => b -> b) -> DDTAnnotation -> DDTAnnotation
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DDTAnnotation -> c DDTAnnotation
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DDTAnnotation
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DDTAnnotation -> u
forall u. (forall d. Data d => d -> u) -> DDTAnnotation -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DDTAnnotation
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DDTAnnotation -> c DDTAnnotation
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DDTAnnotation)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DDTAnnotation)
$cDDTAnnotation :: Constr
$tDDTAnnotation :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
gmapMp :: (forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
gmapM :: (forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DDTAnnotation -> m DDTAnnotation
gmapQi :: Int -> (forall d. Data d => d -> u) -> DDTAnnotation -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DDTAnnotation -> u
gmapQ :: (forall d. Data d => d -> u) -> DDTAnnotation -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DDTAnnotation -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DDTAnnotation -> r
gmapT :: (forall b. Data b => b -> b) -> DDTAnnotation -> DDTAnnotation
$cgmapT :: (forall b. Data b => b -> b) -> DDTAnnotation -> DDTAnnotation
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DDTAnnotation)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DDTAnnotation)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c DDTAnnotation)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DDTAnnotation)
dataTypeOf :: DDTAnnotation -> DataType
$cdataTypeOf :: DDTAnnotation -> DataType
toConstr :: DDTAnnotation -> Constr
$ctoConstr :: DDTAnnotation -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DDTAnnotation
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DDTAnnotation
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DDTAnnotation -> c DDTAnnotation
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DDTAnnotation -> c DDTAnnotation
$cp1Data :: Typeable DDTAnnotation
Data, Typeable, Int -> DDTAnnotation -> ShowS
[DDTAnnotation] -> ShowS
DDTAnnotation -> String
(Int -> DDTAnnotation -> ShowS)
-> (DDTAnnotation -> String)
-> ([DDTAnnotation] -> ShowS)
-> Show DDTAnnotation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DDTAnnotation] -> ShowS
$cshowList :: [DDTAnnotation] -> ShowS
show :: DDTAnnotation -> String
$cshow :: DDTAnnotation -> String
showsPrec :: Int -> DDTAnnotation -> ShowS
$cshowsPrec :: Int -> DDTAnnotation -> ShowS
Show)
-- | Initialize DDTAnnotation
ddtAnnotation0 :: A -> DDTAnnotation
ddtAnnotation0 :: A -> DDTAnnotation
ddtAnnotation0 A
a = A -> Maybe DDTStatement -> Maybe (Block DA) -> DDTAnnotation
DDTAnnotation A
a Maybe DDTStatement
forall a. Maybe a
Nothing Maybe (Block DA)
forall a. Maybe a
Nothing

-- | Annotation used by most analysis in this file.
type DA = FA.Analysis DDTAnnotation

-- | Modify top-level annotation.
onOrigAnnotation :: (A -> A) -> DA -> DA
onOrigAnnotation :: (A -> A) -> DA -> DA
onOrigAnnotation A -> A
f = (DDTAnnotation -> DDTAnnotation) -> DA -> DA
forall a. (a -> a) -> Analysis a -> Analysis a
onPrev ((DDTAnnotation -> DDTAnnotation) -> DA -> DA)
-> (DDTAnnotation -> DDTAnnotation) -> DA -> DA
forall a b. (a -> b) -> a -> b
$ \ DDTAnnotation
a -> DDTAnnotation
a { prevAnnotation :: A
prevAnnotation = A -> A
f (DDTAnnotation -> A
prevAnnotation DDTAnnotation
a) }

-- | Strip annotations used by this file.
stripAnnotations :: Functor f => f DA -> f A
stripAnnotations :: f DA -> f A
stripAnnotations = (DA -> A) -> f DA -> f A
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DDTAnnotation -> A
prevAnnotation (DDTAnnotation -> A) -> (DA -> DDTAnnotation) -> DA -> A
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DA -> DDTAnnotation
forall a. Analysis a -> a
FA.prevAnnotation)

-- Instances for embedding parsed specifications into the AST
instance ASTEmbeddable DA DDTStatement where
  annotateWithAST :: DA -> DDTStatement -> DA
annotateWithAST DA
ann DDTStatement
ast = (DDTAnnotation -> DDTAnnotation) -> DA -> DA
forall a. (a -> a) -> Analysis a -> Analysis a
onPrev (\ DDTAnnotation
ann' -> DDTAnnotation
ann' { ddtSpec :: Maybe DDTStatement
ddtSpec = DDTStatement -> Maybe DDTStatement
forall a. a -> Maybe a
Just DDTStatement
ast }) DA
ann

-- Link annotation comments to declaration statements
instance Linkable DA where
  link :: DA -> Block DA -> DA
link DA
ann b :: Block DA
b@(F.BlStatement DA
_ SrcSpan
_ Maybe (Expression DA)
_ F.StDeclaration{}) = (DDTAnnotation -> DDTAnnotation) -> DA -> DA
forall a. (a -> a) -> Analysis a -> Analysis a
onPrev (\ DDTAnnotation
ann' -> DDTAnnotation
ann' { ddtBlock :: Maybe (Block DA)
ddtBlock = Block DA -> Maybe (Block DA)
forall a. a -> Maybe a
Just Block DA
b }) DA
ann
  link DA
ann Block DA
_ = DA
ann
  linkPU :: DA -> ProgramUnit DA -> DA
linkPU DA
ann ProgramUnit DA
_ = DA
ann -- annotation on PU not needed/supported

--------------------------------------------------
-- Reporting data structures.

-- | Map of information about constants used to index arrays. Nothing
-- implies a non-constant is used to index the array at the given
-- dimension.
--
-- Variable name (unique name) => (dim => maybe constants)
type AMap = M.Map F.Name (IM.IntMap (S.Set (Maybe Int)))

-- | Map of info about vars (unique name).
type VMap = M.Map F.Name (S.Set VInfo)

-- | Map of specification essences connected to var-unique-name(dim)s.
type SMap = M.Map (F.Name, Int) (S.Set Essence)

-- | Info about a variable: source name, source filename, source span.
data VInfo = VInfo { VInfo -> String
vSrcName :: F.Name, VInfo -> String
vFileName :: String, VInfo -> SrcSpan
vSrcSpan :: FU.SrcSpan }
  deriving ((forall x. VInfo -> Rep VInfo x)
-> (forall x. Rep VInfo x -> VInfo) -> Generic VInfo
forall x. Rep VInfo x -> VInfo
forall x. VInfo -> Rep VInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VInfo x -> VInfo
$cfrom :: forall x. VInfo -> Rep VInfo x
Generic, Int -> VInfo -> ShowS
[VInfo] -> ShowS
VInfo -> String
(Int -> VInfo -> ShowS)
-> (VInfo -> String) -> ([VInfo] -> ShowS) -> Show VInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VInfo] -> ShowS
$cshowList :: [VInfo] -> ShowS
show :: VInfo -> String
$cshow :: VInfo -> String
showsPrec :: Int -> VInfo -> ShowS
$cshowsPrec :: Int -> VInfo -> ShowS
Show, VInfo -> VInfo -> Bool
(VInfo -> VInfo -> Bool) -> (VInfo -> VInfo -> Bool) -> Eq VInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VInfo -> VInfo -> Bool
$c/= :: VInfo -> VInfo -> Bool
== :: VInfo -> VInfo -> Bool
$c== :: VInfo -> VInfo -> Bool
Eq)
instance NFData VInfo
instance Binary VInfo

-- special ord instance compares by filename, source span and then name.
instance Ord VInfo where
  VInfo String
s1 String
f1 SrcSpan
ss1 compare :: VInfo -> VInfo -> Ordering
`compare` VInfo String
s2 String
f2 SrcSpan
ss2 = (String
f1, SrcSpan
ss1, String
s1) (String, SrcSpan, String) -> (String, SrcSpan, String) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (String
f2, SrcSpan
ss2, String
s2)

-- | The 'essence' of a specification, in comparable form.
data Essence = Essence { Essence -> String
essTypeName :: String            -- ^ specified type name
                       , Essence -> IntMap String
essLabelMap :: IM.IntMap String  -- ^ specified index => label map
                       , Essence -> Set VInfo
essVInfoSet :: S.Set VInfo       -- ^ location of specified vars
                       , Essence -> Bool
essStarred  :: Bool              -- ^ is this essence 'starred'?
                       }
  deriving (Int -> Essence -> ShowS
[Essence] -> ShowS
Essence -> String
(Int -> Essence -> ShowS)
-> (Essence -> String) -> ([Essence] -> ShowS) -> Show Essence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Essence] -> ShowS
$cshowList :: [Essence] -> ShowS
show :: Essence -> String
$cshow :: Essence -> String
showsPrec :: Int -> Essence -> ShowS
$cshowsPrec :: Int -> Essence -> ShowS
Show, (forall x. Essence -> Rep Essence x)
-> (forall x. Rep Essence x -> Essence) -> Generic Essence
forall x. Rep Essence x -> Essence
forall x. Essence -> Rep Essence x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Essence x -> Essence
$cfrom :: forall x. Essence -> Rep Essence x
Generic)
instance NFData Essence
instance Binary Essence

-- special eq instance: only compare type-name and labels
instance Eq Essence where
  Essence String
ty1 IntMap String
l1 Set VInfo
_ Bool
_ == :: Essence -> Essence -> Bool
== Essence String
ty2 IntMap String
l2 Set VInfo
_ Bool
_ = (String
ty1, IntMap String
l1) (String, IntMap String) -> (String, IntMap String) -> Bool
forall a. Eq a => a -> a -> Bool
== (String
ty2, IntMap String
l2)

-- special ord instance: only compare type-name and labels
instance Ord Essence where
  Essence String
ty1 IntMap String
l1 Set VInfo
_ Bool
_ compare :: Essence -> Essence -> Ordering
`compare` Essence String
ty2 IntMap String
l2 Set VInfo
_ Bool
_ = (String
ty1, IntMap String
l1) (String, IntMap String) -> (String, IntMap String) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (String
ty2, IntMap String
l2)

-- given type name, (source name, span), dupped labels
data IndexError = IndexDupError String VInfo [Int]
                | IndexOOBError String VInfo [Int]
  deriving (Int -> IndexError -> ShowS
[IndexError] -> ShowS
IndexError -> String
(Int -> IndexError -> ShowS)
-> (IndexError -> String)
-> ([IndexError] -> ShowS)
-> Show IndexError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IndexError] -> ShowS
$cshowList :: [IndexError] -> ShowS
show :: IndexError -> String
$cshow :: IndexError -> String
showsPrec :: Int -> IndexError -> ShowS
$cshowsPrec :: Int -> IndexError -> ShowS
Show, IndexError -> IndexError -> Bool
(IndexError -> IndexError -> Bool)
-> (IndexError -> IndexError -> Bool) -> Eq IndexError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IndexError -> IndexError -> Bool
$c/= :: IndexError -> IndexError -> Bool
== :: IndexError -> IndexError -> Bool
$c== :: IndexError -> IndexError -> Bool
Eq, Eq IndexError
Eq IndexError
-> (IndexError -> IndexError -> Ordering)
-> (IndexError -> IndexError -> Bool)
-> (IndexError -> IndexError -> Bool)
-> (IndexError -> IndexError -> Bool)
-> (IndexError -> IndexError -> Bool)
-> (IndexError -> IndexError -> IndexError)
-> (IndexError -> IndexError -> IndexError)
-> Ord IndexError
IndexError -> IndexError -> Bool
IndexError -> IndexError -> Ordering
IndexError -> IndexError -> IndexError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IndexError -> IndexError -> IndexError
$cmin :: IndexError -> IndexError -> IndexError
max :: IndexError -> IndexError -> IndexError
$cmax :: IndexError -> IndexError -> IndexError
>= :: IndexError -> IndexError -> Bool
$c>= :: IndexError -> IndexError -> Bool
> :: IndexError -> IndexError -> Bool
$c> :: IndexError -> IndexError -> Bool
<= :: IndexError -> IndexError -> Bool
$c<= :: IndexError -> IndexError -> Bool
< :: IndexError -> IndexError -> Bool
$c< :: IndexError -> IndexError -> Bool
compare :: IndexError -> IndexError -> Ordering
$ccompare :: IndexError -> IndexError -> Ordering
$cp1Ord :: Eq IndexError
Ord, (forall x. IndexError -> Rep IndexError x)
-> (forall x. Rep IndexError x -> IndexError) -> Generic IndexError
forall x. Rep IndexError x -> IndexError
forall x. IndexError -> Rep IndexError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IndexError x -> IndexError
$cfrom :: forall x. IndexError -> Rep IndexError x
Generic)
instance NFData IndexError
instance Binary IndexError

-- | Variable(dim)s and any conflicting spec essences.
type ConflictErrors = M.Map (F.Name, Int) (S.Set Essence)

-- | Variable(dim)s where the specification has a bad (e.g. duplicated) label name
type BadLabelErrors = M.Map (F.Name, Int) (S.Set (String, VInfo))

-- | Variable(dim)s where the specification has a bad (e.g. duplicated) index
type BadDimErrors = M.Map (F.Name, Int) (S.Set (Int, VInfo))

-- | Collection of information comprising a 'derived datatype' report
-- for CamFort output purposes.
data DerivedDataTypeReport
  = DerivedDataTypeReport { DerivedDataTypeReport -> AMap
ddtrAMap  :: AMap
                          , DerivedDataTypeReport -> VMap
ddtrVMap  :: VMap
                          , DerivedDataTypeReport -> SMap
ddtrSMap  :: SMap
                          , DerivedDataTypeReport -> [DDTStatement]
ddtrSpecs :: [DDTStatement]
                          , DerivedDataTypeReport -> Set IndexError
ddtrIDE   :: (S.Set IndexError)
                          , DerivedDataTypeReport -> SMap
ddtrCE    :: ConflictErrors
                          , DerivedDataTypeReport -> BadLabelErrors
ddtrBLE   :: BadLabelErrors
                          , DerivedDataTypeReport -> BadDimErrors
ddtrBDE   :: BadDimErrors
                          , DerivedDataTypeReport -> Bool
ddtrCheck :: Bool }
  deriving (forall x. DerivedDataTypeReport -> Rep DerivedDataTypeReport x)
-> (forall x. Rep DerivedDataTypeReport x -> DerivedDataTypeReport)
-> Generic DerivedDataTypeReport
forall x. Rep DerivedDataTypeReport x -> DerivedDataTypeReport
forall x. DerivedDataTypeReport -> Rep DerivedDataTypeReport x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DerivedDataTypeReport x -> DerivedDataTypeReport
$cfrom :: forall x. DerivedDataTypeReport -> Rep DerivedDataTypeReport x
Generic
instance NFData DerivedDataTypeReport
instance Binary DerivedDataTypeReport

-- | These reports can be combined, e.g. from multiple files, and the
-- key part is that the problem reports are also combined, and new
-- problems can be identified from the combination of the SMaps.
instance SG.Semigroup DerivedDataTypeReport where
  DerivedDataTypeReport AMap
m1 VMap
v1 SMap
s1 [DDTStatement]
sp1 Set IndexError
ide1 SMap
ce1 BadLabelErrors
ble1 BadDimErrors
bde1 Bool
ch1 <> :: DerivedDataTypeReport
-> DerivedDataTypeReport -> DerivedDataTypeReport
<> DerivedDataTypeReport AMap
m2 VMap
v2 SMap
s2 [DDTStatement]
sp2 Set IndexError
ide2 SMap
ce2 BadLabelErrors
ble2 BadDimErrors
bde2 Bool
ch2 =
    AMap
-> VMap
-> SMap
-> [DDTStatement]
-> Set IndexError
-> SMap
-> BadLabelErrors
-> BadDimErrors
-> Bool
-> DerivedDataTypeReport
DerivedDataTypeReport ((IntMap (Set (Maybe Int))
 -> IntMap (Set (Maybe Int)) -> IntMap (Set (Maybe Int)))
-> AMap -> AMap -> AMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith ((Set (Maybe Int) -> Set (Maybe Int) -> Set (Maybe Int))
-> IntMap (Set (Maybe Int))
-> IntMap (Set (Maybe Int))
-> IntMap (Set (Maybe Int))
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith Set (Maybe Int) -> Set (Maybe Int) -> Set (Maybe Int)
forall a. Ord a => Set a -> Set a -> Set a
S.union) AMap
m1 AMap
m2) ((Set VInfo -> Set VInfo -> Set VInfo) -> VMap -> VMap -> VMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set VInfo -> Set VInfo -> Set VInfo
forall a. Ord a => Set a -> Set a -> Set a
S.union VMap
v1 VMap
v2) SMap
newSMap
                          ([DDTStatement]
sp1 [DDTStatement] -> [DDTStatement] -> [DDTStatement]
forall a. [a] -> [a] -> [a]
++ [DDTStatement]
sp2)
                          (Set IndexError -> Set IndexError -> Set IndexError
forall a. Ord a => Set a -> Set a -> Set a
S.union Set IndexError
ide1 Set IndexError
ide2) ((Set Essence -> Set Essence -> Set Essence) -> [SMap] -> SMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith Set Essence -> Set Essence -> Set Essence
forall a. Ord a => Set a -> Set a -> Set a
S.union [SMap
ce1, SMap
ce2, SMap
newCE])
                          ((Set (String, VInfo) -> Set (String, VInfo) -> Set (String, VInfo))
-> BadLabelErrors -> BadLabelErrors -> BadLabelErrors
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set (String, VInfo) -> Set (String, VInfo) -> Set (String, VInfo)
forall a. Ord a => Set a -> Set a -> Set a
S.union BadLabelErrors
ble1 BadLabelErrors
ble2)
                          ((Set (Int, VInfo) -> Set (Int, VInfo) -> Set (Int, VInfo))
-> BadDimErrors -> BadDimErrors -> BadDimErrors
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Set (Int, VInfo) -> Set (Int, VInfo) -> Set (Int, VInfo)
forall a. Ord a => Set a -> Set a -> Set a
S.union BadDimErrors
bde1 BadDimErrors
bde2)
                          (Bool
ch1 Bool -> Bool -> Bool
&& Bool
ch2)
    where
      -- new conflicts found, if any
      newCE :: SMap
newCE   = (Either (Set Essence) Essence -> Set Essence)
-> Map (String, Int) (Either (Set Essence) Essence) -> SMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Either (Set Essence) Essence -> Set Essence
forall a b. Either a b -> a
SE.fromLeft (Map (String, Int) (Either (Set Essence) Essence) -> SMap)
-> Map (String, Int) (Either (Set Essence) Essence) -> SMap
forall a b. (a -> b) -> a -> b
$ (Either (Set Essence) Essence -> Bool)
-> Map (String, Int) (Either (Set Essence) Essence)
-> Map (String, Int) (Either (Set Essence) Essence)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Either (Set Essence) Essence -> Bool
forall a b. Either a b -> Bool
SE.isLeft Map (String, Int) (Either (Set Essence) Essence)
e_smap
      -- combined SMaps
      newSMap :: SMap
newSMap = (Either (Set Essence) Essence -> Set Essence)
-> Map (String, Int) (Either (Set Essence) Essence) -> SMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Essence -> Set Essence
forall a. a -> Set a
S.singleton (Essence -> Set Essence)
-> (Either (Set Essence) Essence -> Essence)
-> Either (Set Essence) Essence
-> Set Essence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Set Essence) Essence -> Essence
forall a b. Either a b -> b
SE.fromRight) (Map (String, Int) (Either (Set Essence) Essence) -> SMap)
-> Map (String, Int) (Either (Set Essence) Essence) -> SMap
forall a b. (a -> b) -> a -> b
$ (Either (Set Essence) Essence -> Bool)
-> Map (String, Int) (Either (Set Essence) Essence)
-> Map (String, Int) (Either (Set Essence) Essence)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Either (Set Essence) Essence -> Bool
forall a b. Either a b -> Bool
SE.isRight Map (String, Int) (Either (Set Essence) Essence)
e_smap

      -- | Combine the SMaps while looking for new conflicts.
      e_smap :: Map (String, Int) (Either (Set Essence) Essence)
e_smap = (Either (Set Essence) Essence
 -> Either (Set Essence) Essence -> Either (Set Essence) Essence)
-> [((String, Int), Either (Set Essence) Essence)]
-> Map (String, Int) (Either (Set Essence) Essence)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Either (Set Essence) Essence
-> Either (Set Essence) Essence -> Either (Set Essence) Essence
combine [ ((String, Int)
v, Essence -> Either (Set Essence) Essence
forall a b. b -> Either a b
SE.Right Essence
e) | ((String, Int)
v, Set Essence
eSet) <- SMap -> [((String, Int), Set Essence)]
forall k a. Map k a -> [(k, a)]
M.toList SMap
s1 [((String, Int), Set Essence)]
-> [((String, Int), Set Essence)] -> [((String, Int), Set Essence)]
forall a. [a] -> [a] -> [a]
++ SMap -> [((String, Int), Set Essence)]
forall k a. Map k a -> [(k, a)]
M.toList SMap
s2, Essence
e <- Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList Set Essence
eSet ]

      combine :: Either (Set Essence) Essence
-> Either (Set Essence) Essence -> Either (Set Essence) Essence
combine (SE.Left Set Essence
e1) Either (Set Essence) Essence
_              = Set Essence -> Either (Set Essence) Essence
forall a b. a -> Either a b
SE.Left Set Essence
e1
      combine Either (Set Essence) Essence
_ (SE.Left Set Essence
e2)              = Set Essence -> Either (Set Essence) Essence
forall a b. a -> Either a b
SE.Left Set Essence
e2
      combine (SE.Right Essence
e1) (SE.Right Essence
e2) = Essence -> Essence -> Either (Set Essence) Essence
combineEssences Essence
e1 Essence
e2

-- | Combine compatible essences (SE.Right) or else indicate conflict (SE.Left)
combineEssences :: Essence -> Essence -> SE.Either (S.Set Essence) Essence
combineEssences :: Essence -> Essence -> Either (Set Essence) Essence
combineEssences Essence
e1 Essence
e2
  | Essence String
ty1 IntMap String
labMap1 Set VInfo
vinfoSet1 Bool
s1 <- Essence
e1
  , Essence String
ty2 IntMap String
labMap2 Set VInfo
vinfoSet2 Bool
s2 <- Essence
e2 =
    Either (Set Essence) Essence
-> Maybe (Either (Set Essence) Essence)
-> Either (Set Essence) Essence
forall a. a -> Maybe a -> a
fromMaybe (Set Essence -> Either (Set Essence) Essence
forall a b. a -> Either a b
SE.Left (Set Essence -> Either (Set Essence) Essence)
-> Set Essence -> Either (Set Essence) Essence
forall a b. (a -> b) -> a -> b
$ [Essence] -> Set Essence
forall a. Ord a => [a] -> Set a
S.fromList [Essence
e1, Essence
e2]) (Maybe (Either (Set Essence) Essence)
 -> Either (Set Essence) Essence)
-> Maybe (Either (Set Essence) Essence)
-> Either (Set Essence) Essence
forall a b. (a -> b) -> a -> b
$ do
      -- In case of conflict, starred essence info overwrites unstarred essence info.
      --
      -- Compatible type name:
      String
ty <- case () of ()
_ | String
ty1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ty2   -> String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ty1
                         | Bool
s1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
s2 -> String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ty1
                         | Bool -> Bool
not Bool
s1 Bool -> Bool -> Bool
&& Bool
s2 -> String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
ty2
                         | Bool
otherwise    -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      -- Compatible label names:
      let labelStarCombine :: m a -> m a -> m a
labelStarCombine m a
l1 m a
l2 | m a
l1 m a -> m a -> Bool
forall a. Eq a => a -> a -> Bool
== m a
l2     = m a
l1
                                 | Bool
s1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
s2 = m a
l1
                                 | Bool -> Bool
not Bool
s1 Bool -> Bool -> Bool
&& Bool
s2 = m a
l2
                                 | Bool
otherwise    = m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      -- Combined label map:
      IntMap String
labMap <- IntMap (Maybe String) -> Maybe (IntMap String)
forall (m :: * -> *) a. Monad m => IntMap (m a) -> m (IntMap a)
sequenceIntMap (IntMap (Maybe String) -> Maybe (IntMap String))
-> IntMap (Maybe String) -> Maybe (IntMap String)
forall a b. (a -> b) -> a -> b
$ (Maybe String -> Maybe String -> Maybe String)
-> IntMap (Maybe String)
-> IntMap (Maybe String)
-> IntMap (Maybe String)
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a.
(Eq (m a), MonadPlus m) =>
m a -> m a -> m a
labelStarCombine ((String -> Maybe String) -> IntMap String -> IntMap (Maybe String)
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntMap String
labMap1) ((String -> Maybe String) -> IntMap String -> IntMap (Maybe String)
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntMap String
labMap2)
      Either (Set Essence) Essence
-> Maybe (Either (Set Essence) Essence)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Set Essence) Essence
 -> Maybe (Either (Set Essence) Essence))
-> (Essence -> Either (Set Essence) Essence)
-> Essence
-> Maybe (Either (Set Essence) Essence)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Essence -> Either (Set Essence) Essence
forall a b. b -> Either a b
SE.Right (Essence -> Maybe (Either (Set Essence) Essence))
-> Essence -> Maybe (Either (Set Essence) Essence)
forall a b. (a -> b) -> a -> b
$ String -> IntMap String -> Set VInfo -> Bool -> Essence
Essence String
ty IntMap String
labMap (Set VInfo -> Set VInfo -> Set VInfo
forall a. Ord a => Set a -> Set a -> Set a
S.union Set VInfo
vinfoSet1 Set VInfo
vinfoSet2) (Bool
s1 Bool -> Bool -> Bool
|| Bool
s2)

instance Monoid DerivedDataTypeReport where
  mempty :: DerivedDataTypeReport
mempty = AMap
-> VMap
-> SMap
-> [DDTStatement]
-> Set IndexError
-> SMap
-> BadLabelErrors
-> BadDimErrors
-> Bool
-> DerivedDataTypeReport
DerivedDataTypeReport AMap
forall k a. Map k a
M.empty VMap
forall k a. Map k a
M.empty SMap
forall k a. Map k a
M.empty [] Set IndexError
forall a. Set a
S.empty SMap
forall k a. Map k a
M.empty BadLabelErrors
forall k a. Map k a
M.empty BadDimErrors
forall k a. Map k a
M.empty Bool
False
  mappend :: DerivedDataTypeReport
-> DerivedDataTypeReport -> DerivedDataTypeReport
mappend = DerivedDataTypeReport
-> DerivedDataTypeReport -> DerivedDataTypeReport
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | True iff no errors are reported.
successful :: DerivedDataTypeReport -> Bool
successful :: DerivedDataTypeReport -> Bool
successful DerivedDataTypeReport
r = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Set IndexError -> Bool
forall a. Set a -> Bool
S.null (DerivedDataTypeReport -> Set IndexError
ddtrIDE DerivedDataTypeReport
r), SMap -> Bool
forall k a. Map k a -> Bool
M.null (DerivedDataTypeReport -> SMap
ddtrCE DerivedDataTypeReport
r), BadLabelErrors -> Bool
forall k a. Map k a -> Bool
M.null (DerivedDataTypeReport -> BadLabelErrors
ddtrBLE DerivedDataTypeReport
r), BadDimErrors -> Bool
forall k a. Map k a -> Bool
M.null (DerivedDataTypeReport -> BadDimErrors
ddtrBDE DerivedDataTypeReport
r)]

instance ExitCodeOfReport DerivedDataTypeReport where exitCodeOf :: DerivedDataTypeReport -> Int
exitCodeOf DerivedDataTypeReport
r | DerivedDataTypeReport -> Bool
successful DerivedDataTypeReport
r = Int
0 | Bool
otherwise = Int
1

instance Describe DerivedDataTypeReport where
  describeBuilder :: DerivedDataTypeReport -> Builder
describeBuilder r :: DerivedDataTypeReport
r@DerivedDataTypeReport{Bool
[DDTStatement]
AMap
VMap
BadDimErrors
BadLabelErrors
SMap
Set IndexError
ddtrCheck :: Bool
ddtrBDE :: BadDimErrors
ddtrBLE :: BadLabelErrors
ddtrCE :: SMap
ddtrIDE :: Set IndexError
ddtrSpecs :: [DDTStatement]
ddtrSMap :: SMap
ddtrVMap :: VMap
ddtrAMap :: AMap
ddtrCheck :: DerivedDataTypeReport -> Bool
ddtrBDE :: DerivedDataTypeReport -> BadDimErrors
ddtrBLE :: DerivedDataTypeReport -> BadLabelErrors
ddtrCE :: DerivedDataTypeReport -> SMap
ddtrIDE :: DerivedDataTypeReport -> Set IndexError
ddtrSpecs :: DerivedDataTypeReport -> [DDTStatement]
ddtrSMap :: DerivedDataTypeReport -> SMap
ddtrVMap :: DerivedDataTypeReport -> VMap
ddtrAMap :: DerivedDataTypeReport -> AMap
..}
    | Bool -> Bool
not (DerivedDataTypeReport -> Bool
successful DerivedDataTypeReport
r)    = Text -> Builder
Builder.fromText Text
errorReport
    | SMap -> Bool
forall k a. Map k a -> Bool
M.null SMap
ddtrSMap       = Builder
"no cases detected"
    | Bool
ddtrCheck Bool -> Bool -> Bool
&& Int
num Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Builder
"1 specification checked."
    | Bool
ddtrCheck             = Text -> Builder
Builder.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall a. Describe a => a -> Text
describe Int
num Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" specifications checked."
    | Bool
otherwise             = Text -> Builder
Builder.fromText Text
specReport
    where
      num :: Int
num = [DDTStatement] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DDTStatement]
ddtrSpecs
      specReport :: Text
specReport = [(VInfo, [Text])] -> Text
linesByFile [(VInfo, [Text])]
specLines
      specLines :: [(VInfo, [Text])]
specLines = [ (VInfo
vinfo, [String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DerivedDataTypeReport -> (String, String) -> String
genCommentText DerivedDataTypeReport
r (String
var, String
vSrcName)])
                  | ((String
var, Int
_), Set Essence
essenceSet)   <- SMap -> [((String, Int), Set Essence)]
forall k a. Map k a -> [(k, a)]
M.toList SMap
ddtrSMap
                  , Essence{Bool
String
IntMap String
Set VInfo
essStarred :: Bool
essVInfoSet :: Set VInfo
essLabelMap :: IntMap String
essTypeName :: String
essStarred :: Essence -> Bool
essVInfoSet :: Essence -> Set VInfo
essLabelMap :: Essence -> IntMap String
essTypeName :: Essence -> String
..}              <- Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList Set Essence
essenceSet
                  , vinfo :: VInfo
vinfo@VInfo{String
SrcSpan
vSrcSpan :: SrcSpan
vFileName :: String
vSrcName :: String
vSrcSpan :: VInfo -> SrcSpan
vFileName :: VInfo -> String
vSrcName :: VInfo -> String
..}          <- Set VInfo -> [VInfo]
forall a. Set a -> [a]
S.toList Set VInfo
essVInfoSet ]

      ideLines :: [(VInfo, [Text])]
ideLines = [ (VInfo
vinfo, [String -> Text
pack String
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has duplicated indice(s) [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text -> [Text] -> Text
intercalate Text
", " ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Describe a => a -> Text
describe [Int]
ints) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] for variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (VInfo -> String
vSrcName VInfo
vinfo)])
                 | IndexDupError String
ty VInfo
vinfo [Int]
ints <- Set IndexError -> [IndexError]
forall a. Set a -> [a]
S.toList Set IndexError
ddtrIDE ]
      oobLines :: [(VInfo, [Text])]
oobLines = [ (VInfo
vinfo, [String -> Text
pack String
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has out-of-bounds indice(s) [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text -> [Text] -> Text
intercalate Text
", " ((Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Describe a => a -> Text
describe [Int]
ints) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] for variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (VInfo -> String
vSrcName VInfo
vinfo)])
                 | IndexOOBError String
ty VInfo
vinfo [Int]
ints <- Set IndexError -> [IndexError]
forall a. Set a -> [a]
S.toList Set IndexError
ddtrIDE ]
      ceLines :: [(VInfo, [Text])]
ceLines  = [ (VInfo
vinfo, [String -> Text
pack String
ty0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IntMap String -> Text
describeLabels IntMap String
l0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (VInfo -> String
vSrcName VInfo
vinfo) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(dim=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Int -> Text
forall a. Describe a => a -> Text
describe Int
dim Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\nconflicts with\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            [Text] -> Text
unlines [ String -> Text
pack String
fn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Text
forall a. Describe a => a -> Text
describe SrcSpan
ss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
ty Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IntMap String -> Text
describeLabels IntMap String
labs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
                                    | Essence String
ty IntMap String
labs Set VInfo
vinfoSet Bool
_ <- [Essence]
essences
                                    , VInfo String
_ String
fn SrcSpan
ss <- Set VInfo -> [VInfo]
forall a. Set a -> [a]
S.toList Set VInfo
vinfoSet ]])
                 | ((String
_, Int
dim), Set Essence
essenceSet) <- SMap -> [((String, Int), Set Essence)]
forall k a. Map k a -> [(k, a)]
M.toList SMap
ddtrCE
                 , Bool -> Bool
not (Set Essence -> Bool
forall a. Set a -> Bool
S.null Set Essence
essenceSet)
                 , let Essence String
ty0 IntMap String
l0 Set VInfo
vinfoSet0 Bool
_:[Essence]
essences = Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList Set Essence
essenceSet
                 , VInfo
vinfo <- Int -> [VInfo] -> [VInfo]
forall a. Int -> [a] -> [a]
take Int
1 (Set VInfo -> [VInfo]
forall a. Set a -> [a]
S.toList Set VInfo
vinfoSet0) ]
      bleLines :: [(VInfo, [Text])]
bleLines = [ (VInfo
vinfo, [Text
"duplicated label '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
lab Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"', associated with variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            String -> Text
pack (VInfo -> String
vSrcName VInfo
vinfo) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(dim=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Describe a => a -> Text
describe Int
dim Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"])
                 | ((String
_, Int
dim), Set (String, VInfo)
badSet) <- BadLabelErrors -> [((String, Int), Set (String, VInfo))]
forall k a. Map k a -> [(k, a)]
M.toList BadLabelErrors
ddtrBLE
                 , (String
lab, VInfo
vinfo) <- Set (String, VInfo) -> [(String, VInfo)]
forall a. Set a -> [a]
S.toList Set (String, VInfo)
badSet ]
      bdeLines :: [(VInfo, [Text])]
bdeLines = [ (VInfo
vinfo, [String -> Text
pack (VInfo -> String
vSrcName VInfo
vinfo) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": bad dim " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Describe a => a -> Text
describe Int
dim Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            if Int
maxDim Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Text
" less than 1"
                            else Text
" not in range 1.." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Describe a => a -> Text
describe Int
maxDim])
                 | ((String
_, Int
dim), Set (Int, VInfo)
badSet) <- BadDimErrors -> [((String, Int), Set (Int, VInfo))]
forall k a. Map k a -> [(k, a)]
M.toList BadDimErrors
ddtrBDE
                 , (Int
maxDim, VInfo
vinfo) <- Set (Int, VInfo) -> [(Int, VInfo)]
forall a. Set a -> [a]
S.toList Set (Int, VInfo)
badSet ]

      errorReport :: Text
errorReport = [(VInfo, [Text])] -> Text
linesByFile ([(VInfo, [Text])] -> Text) -> [(VInfo, [Text])] -> Text
forall a b. (a -> b) -> a -> b
$ [(VInfo, [Text])]
ideLines [(VInfo, [Text])] -> [(VInfo, [Text])] -> [(VInfo, [Text])]
forall a. [a] -> [a] -> [a]
++ [(VInfo, [Text])]
oobLines [(VInfo, [Text])] -> [(VInfo, [Text])] -> [(VInfo, [Text])]
forall a. [a] -> [a] -> [a]
++ [(VInfo, [Text])]
ceLines [(VInfo, [Text])] -> [(VInfo, [Text])] -> [(VInfo, [Text])]
forall a. [a] -> [a] -> [a]
++ [(VInfo, [Text])]
bleLines [(VInfo, [Text])] -> [(VInfo, [Text])] -> [(VInfo, [Text])]
forall a. [a] -> [a] -> [a]
++ [(VInfo, [Text])]
bdeLines
      describeLabels :: IntMap String -> Text
describeLabels IntMap String
labs = Text -> [Text] -> Text
intercalate Text
", " [Int -> Text
forall a. Describe a => a -> Text
describe Int
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
l | (Int
i,String
l) <- IntMap String -> [(Int, String)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap String
labs]

-- | Return combined text where entries are grouped and sorted by filename, source span
linesByFile :: [(VInfo, [Text])] -> Text
linesByFile :: [(VInfo, [Text])] -> Text
linesByFile [(VInfo, [Text])]
vinfoTexts = [Text] -> Text
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ (Text
"\n"Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>String -> Text
pack String
fileNameText -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
":\n") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [ SrcSpan -> Text
forall a. Describe a => a -> Text
describe SrcSpan
ss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
                                                                           | (SrcSpan
ss, Text
text) <- [(SrcSpan, Text)] -> [(SrcSpan, Text)]
forall a. Ord a => [a] -> [a]
sort [(SrcSpan, Text)]
sstexts ]
                                          | (String
fileName, [(SrcSpan, Text)]
sstexts) <- Map String [(SrcSpan, Text)] -> [(String, [(SrcSpan, Text)])]
forall k a. Map k a -> [(k, a)]
M.toList Map String [(SrcSpan, Text)]
mapByFile ]
  where
    mapByFile :: Map String [(SrcSpan, Text)]
mapByFile = ([(SrcSpan, Text)] -> [(SrcSpan, Text)] -> [(SrcSpan, Text)])
-> [(String, [(SrcSpan, Text)])] -> Map String [(SrcSpan, Text)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [(SrcSpan, Text)] -> [(SrcSpan, Text)] -> [(SrcSpan, Text)]
forall a. [a] -> [a] -> [a]
(++) [ (VInfo -> String
vFileName VInfo
vinfo, (Text -> (SrcSpan, Text)) -> [Text] -> [(SrcSpan, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (VInfo -> SrcSpan
vSrcSpan VInfo
vinfo,) [Text]
texts) | (VInfo
vinfo, [Text]
texts) <- [(VInfo, [Text])]
vinfoTexts ]

--------------------------------------------------
-- External Functionality Interface

-- | Generate report about derived datatypes in given program file
infer :: F.ProgramFile A -> PureAnalysis String () DerivedDataTypeReport
infer :: ProgramFile A -> PureAnalysis String () DerivedDataTypeReport
infer ProgramFile A
pf = do
  ModFiles
mfs <- AnalysisT String () Identity ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
  DerivedDataTypeReport
-> PureAnalysis String () DerivedDataTypeReport
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivedDataTypeReport
 -> PureAnalysis String () DerivedDataTypeReport)
-> ((DerivedDataTypeReport, ProgramFile DA)
    -> DerivedDataTypeReport)
-> (DerivedDataTypeReport, ProgramFile DA)
-> PureAnalysis String () DerivedDataTypeReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DerivedDataTypeReport, ProgramFile DA) -> DerivedDataTypeReport
forall a b. (a, b) -> a
fst ((DerivedDataTypeReport, ProgramFile DA)
 -> PureAnalysis String () DerivedDataTypeReport)
-> (DerivedDataTypeReport, ProgramFile DA)
-> PureAnalysis String () DerivedDataTypeReport
forall a b. (a -> b) -> a -> b
$ ModFiles
-> ProgramFile A -> (DerivedDataTypeReport, ProgramFile DA)
genProgramFileReport ModFiles
mfs ProgramFile A
pf

-- | Check annotations relating to derived datatypes in given program file
check :: F.ProgramFile A -> PureAnalysis String () DerivedDataTypeReport
check :: ProgramFile A -> PureAnalysis String () DerivedDataTypeReport
check ProgramFile A
pf = do
  ModFiles
mfs <- AnalysisT String () Identity ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
  DerivedDataTypeReport
-> PureAnalysis String () DerivedDataTypeReport
forall (m :: * -> *) a. Monad m => a -> m a
return ((DerivedDataTypeReport, ProgramFile DA) -> DerivedDataTypeReport
forall a b. (a, b) -> a
fst ((DerivedDataTypeReport, ProgramFile DA) -> DerivedDataTypeReport)
-> (DerivedDataTypeReport, ProgramFile DA) -> DerivedDataTypeReport
forall a b. (a -> b) -> a -> b
$ ModFiles
-> ProgramFile A -> (DerivedDataTypeReport, ProgramFile DA)
genProgramFileReport ModFiles
mfs ProgramFile A
pf) { ddtrCheck :: Bool
ddtrCheck = Bool
True }
  -- FIXME: check that a user-supplied spec doesn't conflict with something disqualifying in the code

-- | Generate and insert comments about derived datatypes
synth :: Char -> [F.ProgramFile A] -> PureAnalysis String () (DerivedDataTypeReport, [Either String (F.ProgramFile A)])
synth :: Char
-> [ProgramFile A]
-> PureAnalysis
     String () (DerivedDataTypeReport, [Either String (ProgramFile A)])
synth Char
marker [ProgramFile A]
pfs = do
  ModFiles
mfs <- AnalysisT String () Identity ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
  [ProgramFile A]
-> (ProgramFile A
    -> AnalysisT
         String
         ()
         Identity
         (DerivedDataTypeReport, Either String (ProgramFile A)))
-> PureAnalysis
     String () (DerivedDataTypeReport, [Either String (ProgramFile A)])
forall (m :: * -> *) r a b.
(Monad m, Monoid r) =>
[a] -> (a -> m (r, b)) -> m (r, [b])
forEachProgramFile [ProgramFile A]
pfs ((ProgramFile A
  -> AnalysisT
       String
       ()
       Identity
       (DerivedDataTypeReport, Either String (ProgramFile A)))
 -> PureAnalysis
      String () (DerivedDataTypeReport, [Either String (ProgramFile A)]))
-> (ProgramFile A
    -> AnalysisT
         String
         ()
         Identity
         (DerivedDataTypeReport, Either String (ProgramFile A)))
-> PureAnalysis
     String () (DerivedDataTypeReport, [Either String (ProgramFile A)])
forall a b. (a -> b) -> a -> b
$ \ ProgramFile A
pf -> do
    let (DerivedDataTypeReport
report, pf' :: ProgramFile DA
pf'@(F.ProgramFile MetaInfo
mi [ProgramUnit DA]
_)) = ModFiles
-> ProgramFile A -> (DerivedDataTypeReport, ProgramFile DA)
genProgramFileReport ModFiles
mfs ProgramFile A
pf
    let synthedPF :: ProgramFile DA
synthedPF = ([Block DA] -> [Block DA]) -> ProgramFile DA -> ProgramFile DA
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi ((MetaInfo, Char)
-> DerivedDataTypeReport -> [Block DA] -> [Block DA]
synthBlocks (MetaInfo
mi, Char
marker) DerivedDataTypeReport
report) ProgramFile DA
pf'
    let strippedPF :: Either String (ProgramFile A)
strippedPF | DerivedDataTypeReport -> Bool
successful DerivedDataTypeReport
report = ProgramFile A -> Either String (ProgramFile A)
forall a b. b -> Either a b
Right (ProgramFile DA -> ProgramFile A
forall (f :: * -> *). Functor f => f DA -> f A
stripAnnotations ProgramFile DA
synthedPF)
                   | Bool
otherwise         = String -> Either String (ProgramFile A)
forall a b. a -> Either a b
Left String
"error"
    (DerivedDataTypeReport, Either String (ProgramFile A))
-> AnalysisT
     String
     ()
     Identity
     (DerivedDataTypeReport, Either String (ProgramFile A))
forall (m :: * -> *) a. Monad m => a -> m a
return ((DerivedDataTypeReport, Either String (ProgramFile A))
 -> AnalysisT
      String
      ()
      Identity
      (DerivedDataTypeReport, Either String (ProgramFile A)))
-> (DerivedDataTypeReport, Either String (ProgramFile A))
-> AnalysisT
     String
     ()
     Identity
     (DerivedDataTypeReport, Either String (ProgramFile A))
forall a b. (a -> b) -> a -> b
$ (DerivedDataTypeReport
report, Either String (ProgramFile A)
strippedPF)

-- | Refactor derived datatypes based on marked comments
refactor :: [F.ProgramFile A] -> PureAnalysis String () (DerivedDataTypeReport, [Either String (F.ProgramFile A)])
refactor :: [ProgramFile A]
-> PureAnalysis
     String () (DerivedDataTypeReport, [Either String (ProgramFile A)])
refactor [ProgramFile A]
pfs = do
  ModFiles
mfs <- AnalysisT String () Identity ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
  [ProgramFile A]
-> (ProgramFile A
    -> AnalysisT
         String
         ()
         Identity
         (DerivedDataTypeReport, Either String (ProgramFile A)))
-> PureAnalysis
     String () (DerivedDataTypeReport, [Either String (ProgramFile A)])
forall (m :: * -> *) r a b.
(Monad m, Monoid r) =>
[a] -> (a -> m (r, b)) -> m (r, [b])
forEachProgramFile [ProgramFile A]
pfs ((ProgramFile A
  -> AnalysisT
       String
       ()
       Identity
       (DerivedDataTypeReport, Either String (ProgramFile A)))
 -> PureAnalysis
      String () (DerivedDataTypeReport, [Either String (ProgramFile A)]))
-> (ProgramFile A
    -> AnalysisT
         String
         ()
         Identity
         (DerivedDataTypeReport, Either String (ProgramFile A)))
-> PureAnalysis
     String () (DerivedDataTypeReport, [Either String (ProgramFile A)])
forall a b. (a -> b) -> a -> b
$ \ ProgramFile A
pf -> do
    let (DerivedDataTypeReport
report, ProgramFile DA
pf') = ModFiles
-> ProgramFile A -> (DerivedDataTypeReport, ProgramFile DA)
genProgramFileReport ModFiles
mfs ProgramFile A
pf
    let smap :: SMap
smap = (Set Essence -> Bool) -> SMap -> SMap
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> (Set Essence -> Bool) -> Set Essence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Essence -> Bool
forall a. Set a -> Bool
S.null) (SMap -> SMap) -> (SMap -> SMap) -> SMap -> SMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Essence -> Set Essence) -> SMap -> SMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Essence -> Bool) -> Set Essence -> Set Essence
forall a. (a -> Bool) -> Set a -> Set a
S.filter Essence -> Bool
essStarred) (SMap -> SMap) -> SMap -> SMap
forall a b. (a -> b) -> a -> b
$ DerivedDataTypeReport -> SMap
ddtrSMap DerivedDataTypeReport
report
    let amap :: AMap
amap = (IntMap (Set (Maybe Int)) -> Bool) -> AMap -> AMap
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (IntMap (Set (Maybe Int)) -> Bool)
-> IntMap (Set (Maybe Int))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (Set (Maybe Int)) -> Bool
forall a. IntMap a -> Bool
IM.null) (AMap -> AMap) -> (AMap -> AMap) -> AMap -> AMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IntMap (Set (Maybe Int)) -> IntMap (Set (Maybe Int)))
-> AMap -> AMap
forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey String -> IntMap (Set (Maybe Int)) -> IntMap (Set (Maybe Int))
forall a. String -> IntMap a -> IntMap a
cullDims (AMap -> AMap) -> AMap -> AMap
forall a b. (a -> b) -> a -> b
$ DerivedDataTypeReport -> AMap
ddtrAMap DerivedDataTypeReport
report
          where cullDims :: String -> IntMap a -> IntMap a
cullDims String
var = (Int -> a -> Bool) -> IntMap a -> IntMap a
forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IM.filterWithKey (\ Int
dim a
_ -> (String, Int) -> SMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (String
var, Int
dim) SMap
smap)
    let report' :: DerivedDataTypeReport
report' = DerivedDataTypeReport
report { ddtrSMap :: SMap
ddtrSMap = SMap
smap, ddtrAMap :: AMap
ddtrAMap = AMap
amap }
    if SMap -> Bool
forall k a. Map k a -> Bool
M.null SMap
smap
      then (DerivedDataTypeReport, Either String (ProgramFile A))
-> AnalysisT
     String
     ()
     Identity
     (DerivedDataTypeReport, Either String (ProgramFile A))
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivedDataTypeReport
report', String -> Either String (ProgramFile A)
forall a b. a -> Either a b
Left String
"nothing to do")
      else (DerivedDataTypeReport, Either String (ProgramFile A))
-> AnalysisT
     String
     ()
     Identity
     (DerivedDataTypeReport, Either String (ProgramFile A))
forall (m :: * -> *) a. Monad m => a -> m a
return (DerivedDataTypeReport
report', ProgramFile A -> Either String (ProgramFile A)
forall a b. b -> Either a b
Right (ProgramFile A -> Either String (ProgramFile A))
-> (ProgramFile DA -> ProgramFile A)
-> ProgramFile DA
-> Either String (ProgramFile A)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile DA -> ProgramFile A
forall (f :: * -> *). Functor f => f DA -> f A
stripAnnotations (ProgramFile DA -> Either String (ProgramFile A))
-> ProgramFile DA -> Either String (ProgramFile A)
forall a b. (a -> b) -> a -> b
$ DerivedDataTypeReport -> ProgramFile DA -> ProgramFile DA
refactorPF DerivedDataTypeReport
report' ProgramFile DA
pf')

-- | Compile a program to a 'ModFile' containing derived datatype information.
compile :: () -> ModFiles -> F.ProgramFile A -> IO ModFile
compile :: () -> ModFiles -> ProgramFile A -> IO ModFile
compile ()
_ ModFiles
mfs ProgramFile A
pf = do
  let (DerivedDataTypeReport
report, ProgramFile DA
pf') = ModFiles
-> ProgramFile A -> (DerivedDataTypeReport, ProgramFile DA)
genProgramFileReport ModFiles
mfs ProgramFile A
pf
  ModFile -> IO ModFile
forall (m :: * -> *) a. Monad m => a -> m a
return (ModFile -> IO ModFile) -> ModFile -> IO ModFile
forall a b. (a -> b) -> a -> b
$ ProgramFile DA -> DerivedDataTypeReport -> ModFile
forall a.
Data a =>
ProgramFile (Analysis a) -> DerivedDataTypeReport -> ModFile
genDDTModFile ProgramFile DA
pf' DerivedDataTypeReport
report

--------------------------------------------------
-- Analysis helpers

-- | Perform monadic action on each, which returns a pair. The fst
-- elements of the pairs is combined with (<>) and the second elements
-- of the pairs are returned in a list.
forEachProgramFile :: (Monad m, Monoid r) => [a] -> (a -> m (r, b)) -> m (r, [b])
forEachProgramFile :: [a] -> (a -> m (r, b)) -> m (r, [b])
forEachProgramFile [a]
pfs a -> m (r, b)
f = do
  [(r, b)]
results <- (a -> m (r, b)) -> [a] -> m [(r, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m (r, b)
f [a]
pfs
  (r, [b]) -> m (r, [b])
forall (m :: * -> *) a. Monad m => a -> m a
return ((r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' r -> r -> r
forall a. Semigroup a => a -> a -> a
(<>) r
forall a. Monoid a => a
mempty (((r, b) -> r) -> [(r, b)] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map (r, b) -> r
forall a b. (a, b) -> a
fst [(r, b)]
results), ((r, b) -> b) -> [(r, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (r, b) -> b
forall a b. (a, b) -> b
snd [(r, b)]
results)

-- | Performs analysis about a single program file and returns a
-- report containing the essences and problems detected, as well as an
-- annotated program file for further usage.
genProgramFileReport :: ModFiles -> F.ProgramFile A -> (DerivedDataTypeReport, F.ProgramFile DA)
genProgramFileReport :: ModFiles
-> ProgramFile A -> (DerivedDataTypeReport, ProgramFile DA)
genProgramFileReport ModFiles
mfs (pf :: ProgramFile A
pf@(F.ProgramFile F.MetaInfo{ miFilename :: MetaInfo -> String
F.miFilename = String
srcFile } [ProgramUnit A]
_)) = (DerivedDataTypeReport
report, ProgramFile DA
pf')
  where
    (AMap
amap, ProgramFile DA
pf', TypeEnv
tenv) = ModFiles -> ProgramFile A -> (AMap, ProgramFile DA, TypeEnv)
analysis ModFiles
mfs ProgramFile A
pf
    vars :: Set String
vars = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ AMap -> [String]
forall k a. Map k a -> [k]
M.keys AMap
amap
    vls1 :: [(String, Set VInfo)]
vls1 = [ (String
v, VInfo -> Set VInfo
forall a. a -> Set a
S.singleton (VInfo -> Set VInfo) -> VInfo -> Set VInfo
forall a b. (a -> b) -> a -> b
$ String -> String -> SrcSpan -> VInfo
VInfo (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.srcName Expression DA
e) String
srcFile SrcSpan
ss)
           | F.DeclArray DA
_ SrcSpan
ss Expression DA
e AList DimensionDeclarator DA
_ Maybe (Expression DA)
_ Maybe (Expression DA)
_ <- ProgramFile DA -> [Declarator DA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile DA
pf' :: [F.Declarator DA]
           , let v :: String
v = Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression DA
e
           , String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
vars ]
    vls2 :: [(String, Set VInfo)]
vls2 = [ (String
v, VInfo -> Set VInfo
forall a. a -> Set a
S.singleton (VInfo -> Set VInfo) -> VInfo -> Set VInfo
forall a b. (a -> b) -> a -> b
$ String -> String -> SrcSpan -> VInfo
VInfo (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.srcName Expression DA
e) String
srcFile SrcSpan
ss)
           | F.DeclVariable DA
_ SrcSpan
ss Expression DA
e Maybe (Expression DA)
_ Maybe (Expression DA)
_ <- ProgramFile DA -> [Declarator DA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile DA
pf' :: [F.Declarator DA]
           , let v :: String
v = Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression DA
e
           , String
v String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
vars ]
    vmap :: VMap
vmap = (Set VInfo -> Set VInfo -> Set VInfo)
-> [(String, Set VInfo)] -> VMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set VInfo -> Set VInfo -> Set VInfo
forall a. Ord a => Set a -> Set a -> Set a
S.union ([(String, Set VInfo)] -> VMap) -> [(String, Set VInfo)] -> VMap
forall a b. (a -> b) -> a -> b
$ [(String, Set VInfo)]
vls1 [(String, Set VInfo)]
-> [(String, Set VInfo)] -> [(String, Set VInfo)]
forall a. [a] -> [a] -> [a]
++ [(String, Set VInfo)]
vls2

    specs :: [(DDTStatement, Block DA)]
specs = [ (DDTStatement
spec, Block DA
b) | DDTAnnotation { ddtSpec :: DDTAnnotation -> Maybe DDTStatement
ddtSpec = Just DDTStatement
spec, ddtBlock :: DDTAnnotation -> Maybe (Block DA)
ddtBlock = Just Block DA
b } <- ProgramFile DA -> [DDTAnnotation]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile DA
pf' ]

    -- Boil down the specs parsed from the comments.
    e_essences :: [((String, Int), Either IndexError Essence)]
e_essences = [ ((String, Int), Either IndexError Essence)
essMapping | (spec :: DDTStatement
spec@DDTSt{Bool
String
[(String, Int)]
[(String, String)]
ddtStVarDims :: DDTStatement -> [(String, Int)]
ddtStLabels :: DDTStatement -> [(String, String)]
ddtStTypeName :: DDTStatement -> String
ddtStStarred :: DDTStatement -> Bool
ddtStVarDims :: [(String, Int)]
ddtStLabels :: [(String, String)]
ddtStTypeName :: String
ddtStStarred :: Bool
..}, Block DA
b)  <- [(DDTStatement, Block DA)]
specs
                              , (String
var, Int
dim)           <- [(String, Int)]
ddtStVarDims
                              , (String
declVarName, VInfo
vinfo) <- String -> Block DA -> [(String, VInfo)]
forall (f :: * -> *).
Data (f DA) =>
String -> f DA -> [(String, VInfo)]
declaredVars String
srcFile Block DA
b
                              , VInfo -> String
vSrcName VInfo
vinfo String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
var
                              , let essMapping :: ((String, Int), Either IndexError Essence)
essMapping = ((String
declVarName, Int
dim), DDTStatement -> VInfo -> Either IndexError Essence
distil DDTStatement
spec VInfo
vinfo) ]
    ([((String, Int), Either IndexError Essence)]
l_errors, [((String, Int), Either IndexError Essence)]
r_essences) = (((String, Int), Either IndexError Essence) -> Bool)
-> [((String, Int), Either IndexError Essence)]
-> ([((String, Int), Either IndexError Essence)],
    [((String, Int), Either IndexError Essence)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (Either IndexError Essence -> Bool
forall a b. Either a b -> Bool
SE.isLeft (Either IndexError Essence -> Bool)
-> (((String, Int), Either IndexError Essence)
    -> Either IndexError Essence)
-> ((String, Int), Either IndexError Essence)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Int), Either IndexError Essence)
-> Either IndexError Essence
forall a b. (a, b) -> b
snd) [((String, Int), Either IndexError Essence)]
e_essences

    -- Dupped indices:
    dupIndices :: Set IndexError
dupIndices = [IndexError] -> Set IndexError
forall a. Ord a => [a] -> Set a
S.fromList ([IndexError] -> Set IndexError) -> [IndexError] -> Set IndexError
forall a b. (a -> b) -> a -> b
$ (((String, Int), Either IndexError Essence) -> IndexError)
-> [((String, Int), Either IndexError Essence)] -> [IndexError]
forall a b. (a -> b) -> [a] -> [b]
map (Either IndexError Essence -> IndexError
forall a b. Either a b -> a
SE.fromLeft (Either IndexError Essence -> IndexError)
-> (((String, Int), Either IndexError Essence)
    -> Either IndexError Essence)
-> ((String, Int), Either IndexError Essence)
-> IndexError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Int), Either IndexError Essence)
-> Either IndexError Essence
forall a b. (a, b) -> b
snd) [((String, Int), Either IndexError Essence)]
l_errors

    essences :: M.Map (F.Name, Int) (S.Set Essence)
    essences :: SMap
essences = (Set Essence -> Set Essence -> Set Essence)
-> [((String, Int), Set Essence)] -> SMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set Essence -> Set Essence -> Set Essence
forall a. Ord a => Set a -> Set a -> Set a
S.union ([((String, Int), Set Essence)] -> SMap)
-> [((String, Int), Set Essence)] -> SMap
forall a b. (a -> b) -> a -> b
$ (((String, Int), Either IndexError Essence)
 -> ((String, Int), Set Essence))
-> [((String, Int), Either IndexError Essence)]
-> [((String, Int), Set Essence)]
forall a b. (a -> b) -> [a] -> [b]
map ((Either IndexError Essence -> Set Essence)
-> ((String, Int), Either IndexError Essence)
-> ((String, Int), Set Essence)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Essence -> Set Essence
forall a. a -> Set a
S.singleton (Essence -> Set Essence)
-> (Either IndexError Essence -> Essence)
-> Either IndexError Essence
-> Set Essence
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either IndexError Essence -> Essence
forall a b. Either a b -> b
SE.fromRight)) [((String, Int), Either IndexError Essence)]
r_essences

    -- Conflicting specs:
    conflicts :: SMap
conflicts = (Set Essence -> Bool) -> SMap -> SMap
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1) (Int -> Bool) -> (Set Essence -> Int) -> Set Essence -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Essence -> Int
forall a. Set a -> Int
S.size) SMap
essences
    findDupLabels :: Essence -> [(String, VInfo)]
findDupLabels Essence{Bool
String
IntMap String
Set VInfo
essStarred :: Bool
essVInfoSet :: Set VInfo
essLabelMap :: IntMap String
essTypeName :: String
essStarred :: Essence -> Bool
essVInfoSet :: Essence -> Set VInfo
essLabelMap :: Essence -> IntMap String
essTypeName :: Essence -> String
..} = [ (String
lab, VInfo
vinfo) | String
lab <- [String]
labs, VInfo
vinfo <- [VInfo]
vinfos ]
      where
        vinfos :: [VInfo]
vinfos = Set VInfo -> [VInfo]
forall a. Set a -> [a]
S.toList Set VInfo
essVInfoSet
        -- Labels that appear more than once in the label map:
        labs :: [String]
labs = Map String Int -> [String]
forall k a. Map k a -> [k]
M.keys (Map String Int -> [String])
-> ([String] -> Map String Int) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> Map String Int -> Map String Int
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1) (Map String Int -> Map String Int)
-> ([String] -> Map String Int) -> [String] -> Map String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> [(String, Int)] -> Map String Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([(String, Int)] -> Map String Int)
-> ([String] -> [(String, Int)]) -> [String] -> Map String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (String, Int)) -> [String] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (,Int
1::Int) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ IntMap String -> [String]
forall a. IntMap a -> [a]
IM.elems IntMap String
essLabelMap

    -- Dupped labels:
    badLabels :: BadLabelErrors
badLabels = (Set (String, VInfo) -> Bool) -> BadLabelErrors -> BadLabelErrors
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (Set (String, VInfo) -> Bool) -> Set (String, VInfo) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (String, VInfo) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (BadLabelErrors -> BadLabelErrors)
-> BadLabelErrors -> BadLabelErrors
forall a b. (a -> b) -> a -> b
$ (Set Essence -> Set (String, VInfo)) -> SMap -> BadLabelErrors
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Essence -> [(String, VInfo)])
-> Set Essence -> Set (String, VInfo)
forall a b. (Ord a, Ord b) => (a -> [b]) -> Set a -> Set b
setConcatMap Essence -> [(String, VInfo)]
findDupLabels) SMap
essences

    -- Badly specified 'dim' attributes (e.g. out of bounds):
    badDims :: [((String, Int), Set (Int, VInfo))]
badDims = [ ((String
declVarName, Int
dim), (Int, VInfo) -> Set (Int, VInfo)
forall a. a -> Set a
S.singleton (Int
maxDim, VInfo
vinfo))
              | (DDTSt{Bool
String
[(String, Int)]
[(String, String)]
ddtStVarDims :: [(String, Int)]
ddtStLabels :: [(String, String)]
ddtStTypeName :: String
ddtStStarred :: Bool
ddtStVarDims :: DDTStatement -> [(String, Int)]
ddtStLabels :: DDTStatement -> [(String, String)]
ddtStTypeName :: DDTStatement -> String
ddtStStarred :: DDTStatement -> Bool
..}, Block DA
b)       <- [(DDTStatement, Block DA)]
specs
              , (String
srcName, Int
dim)       <- [(String, Int)]
ddtStVarDims
              , (String
declVarName, VInfo
vinfo) <- String -> Block DA -> [(String, VInfo)]
forall (f :: * -> *).
Data (f DA) =>
String -> f DA -> [(String, VInfo)]
declaredVars String
srcFile Block DA
b
              , VInfo -> String
vSrcName VInfo
vinfo String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
srcName
              , Just Int
maxDim <- [ do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1)
                                    Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0  -- Stand-in number for 'dim violates the lower bound' case.
                                 Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                                 do FA.IDType { idCType :: IDType -> Maybe ConstructType
FA.idCType = Just (FA.CTArray [(Maybe Int, Maybe Int)]
dims) } <- String -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
declVarName TypeEnv
tenv
                                    let maxDim :: Int
maxDim = [(Maybe Int, Maybe Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Int, Maybe Int)]
dims
                                    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not ([(Maybe Int, Maybe Int)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe Int, Maybe Int)]
dims Bool -> Bool -> Bool
|| Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxDim)
                                    -- There is a known upper-bound and dim violates it.
                                    Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
maxDim ] ]

    -- Index out-of-bounds of statically-known array dimensions:
    oobIndices :: [IndexError]
oobIndices = [ String -> VInfo -> [Int] -> IndexError
IndexOOBError String
tyname VInfo
vinfo [Int]
indices
                 | (DDTSt{Bool
String
[(String, Int)]
[(String, String)]
ddtStVarDims :: [(String, Int)]
ddtStLabels :: [(String, String)]
ddtStTypeName :: String
ddtStStarred :: Bool
ddtStVarDims :: DDTStatement -> [(String, Int)]
ddtStLabels :: DDTStatement -> [(String, String)]
ddtStTypeName :: DDTStatement -> String
ddtStStarred :: DDTStatement -> Bool
..}, Block DA
b)       <- [(DDTStatement, Block DA)]
specs
                 , (String
srcName, Int
dim)       <- [(String, Int)]
ddtStVarDims
                 , (String
declVarName, VInfo
vinfo) <- String -> Block DA -> [(String, VInfo)]
forall (f :: * -> *).
Data (f DA) =>
String -> f DA -> [(String, VInfo)]
declaredVars String
srcFile Block DA
b
                 , let tyname :: String
tyname = String
""
                 , VInfo -> String
vSrcName VInfo
vinfo String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
srcName
                 , Just [Int]
indices <- [ do FA.IDType { idCType :: IDType -> Maybe ConstructType
FA.idCType = Just (FA.CTArray [(Maybe Int, Maybe Int)]
dims) } <- String -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
declVarName TypeEnv
tenv
                                        let maxDim :: Int
maxDim = [(Maybe Int, Maybe Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Int, Maybe Int)]
dims
                                        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxDim
                                        let (Maybe Int
mminBound, Maybe Int
mmaxBound) = [(Maybe Int, Maybe Int)]
dims [(Maybe Int, Maybe Int)] -> Int -> (Maybe Int, Maybe Int)
forall a. [a] -> Int -> a
!! (Int
dim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                                        let minBound :: Int
minBound = Int
1 Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
`fromMaybe` Maybe Int
mminBound
                                        Int
maxBound <- Maybe Int
mmaxBound
                                        let indices :: [Int]
indices = [ String -> Int
forall a. Read a => String -> a
read String
i | (String
i, String
_) <- [(String, String)]
ddtStLabels ]
                                        let oob :: [Int]
oob = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(||) ((Bool, Bool) -> Bool) -> (Int -> (Bool, Bool)) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minBound) (Int -> Bool) -> (Int -> Bool) -> Int -> (Bool, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxBound))) [Int]
indices
                                        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> ([Int] -> Bool) -> [Int] -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> ([Int] -> Bool) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Int] -> Maybe ()) -> [Int] -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Int]
oob
                                        -- oob is the list of indices out-of-bounds
                                        [Int] -> Maybe [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int]
oob ] ]

    -- Distil specs from the inferred AMap:
    smapFromAMap :: SMap
smapFromAMap = [((String, Int), Set Essence)] -> SMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ ((String
v, Int
dim), Set Essence
essenceSet) | (String
v, IntMap (Set (Maybe Int))
aminfoMap) <- AMap -> [(String, IntMap (Set (Maybe Int)))]
forall k a. Map k a -> [(k, a)]
M.toList AMap
amap
                                                       , (Int
dim, Set (Maybe Int)
aminfo)  <- IntMap (Set (Maybe Int)) -> [(Int, Set (Maybe Int))]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (Set (Maybe Int))
aminfoMap
                                                       , (Maybe Int -> Bool) -> [Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Set (Maybe Int) -> [Maybe Int]
forall a. Set a -> [a]
S.toList Set (Maybe Int)
aminfo)
                                                       , Just Set VInfo
vinfoSet  <- [String -> VMap -> Maybe (Set VInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
v VMap
vmap]
                                                       , let e :: Essence
e = String -> Set VInfo -> Set Int -> Essence
distilArrayInfo String
v Set VInfo
vinfoSet ((Maybe Int -> Int) -> Set (Maybe Int) -> Set Int
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Set (Maybe Int)
aminfo)
                                                       , let essenceSet :: Set Essence
essenceSet = Essence -> Set Essence
forall a. a -> Set a
S.singleton Essence
e ]
    -- Specs in the file override inferred specs:
    smap :: SMap
smap = (Set Essence -> Set Essence -> Set Essence) -> SMap -> SMap -> SMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (((Set Essence, Set Essence) -> Set Essence)
-> Set Essence -> Set Essence -> Set Essence
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Set Essence, Set Essence) -> Set Essence
forall a b. (a, b) -> a
fst) SMap
essences SMap
smapFromAMap

    ide :: Set IndexError
ide  = Set IndexError
dupIndices Set IndexError -> Set IndexError -> Set IndexError
forall a. Ord a => Set a -> Set a -> Set a
`S.union` [IndexError] -> Set IndexError
forall a. Ord a => [a] -> Set a
S.fromList [IndexError]
oobIndices
    ce :: SMap
ce   = SMap
conflicts
    ble :: BadLabelErrors
ble  = BadLabelErrors
badLabels
    bde :: BadDimErrors
bde  = [((String, Int), Set (Int, VInfo))] -> BadDimErrors
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((String, Int), Set (Int, VInfo))]
badDims
    -- Combine this report with those reports read from modfiles:
    report :: DerivedDataTypeReport
report = AMap
-> VMap
-> SMap
-> [DDTStatement]
-> Set IndexError
-> SMap
-> BadLabelErrors
-> BadDimErrors
-> Bool
-> DerivedDataTypeReport
DerivedDataTypeReport AMap
amap VMap
vmap SMap
smap (((DDTStatement, Block DA) -> DDTStatement)
-> [(DDTStatement, Block DA)] -> [DDTStatement]
forall a b. (a -> b) -> [a] -> [b]
map (DDTStatement, Block DA) -> DDTStatement
forall a b. (a, b) -> a
fst [(DDTStatement, Block DA)]
specs) Set IndexError
ide SMap
ce BadLabelErrors
ble BadDimErrors
bde Bool
False DerivedDataTypeReport
-> DerivedDataTypeReport -> DerivedDataTypeReport
forall a. Semigroup a => a -> a -> a
<> ModFiles -> DerivedDataTypeReport
combinedDerivedDataTypeReport ModFiles
mfs

-- | Analyse and return an AMap, a spec-linked ProgramFile and a type
-- environment (convenience). The AMap contains derived information
-- about array accesses that appear to be in a 'category 1' pattern,
-- namely whether the array is accessed at the particular dimension
-- only by constants.
analysis :: ModFiles -> F.ProgramFile A -> (AMap, F.ProgramFile DA, FAT.TypeEnv)
analysis :: ModFiles -> ProgramFile A -> (AMap, ProgramFile DA, TypeEnv)
analysis ModFiles
mfs ProgramFile A
pf = (AMap
amap', ProgramFile DA
linkedPF, TypeEnv
tenv)
  -- FIXME: check for violations of the 'only one array deref in a path' rule
  where
     (ProgramFile DA
pf', ModuleMap
_, TypeEnv
tenv) = ModFiles
-> ProgramFile DDTAnnotation
-> (ProgramFile DA, ModuleMap, TypeEnv)
forall a.
Data a =>
ModFiles
-> ProgramFile a -> (ProgramFile (Analysis a), ModuleMap, TypeEnv)
withCombinedEnvironment ModFiles
mfs ((A -> DDTAnnotation) -> ProgramFile A -> ProgramFile DDTAnnotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap A -> DDTAnnotation
ddtAnnotation0 ProgramFile A
pf)
     pf'' :: ProgramFile DA
pf''           = ProgramFile DA -> ProgramFile DA
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAD.analyseConstExps (ProgramFile DA -> ProgramFile DA)
-> ProgramFile DA -> ProgramFile DA
forall a b. (a -> b) -> a -> b
$ ProgramFile DA -> ProgramFile DA
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAB.analyseBBlocks ProgramFile DA
pf'

     -- Link specifications (in comments) to associated AST-blocks:
     (ProgramFile DA
linkedPF, String
_) = Writer String (ProgramFile DA) -> (ProgramFile DA, String)
forall w a. Writer w a -> (a, w)
runWriter (Writer String (ProgramFile DA) -> (ProgramFile DA, String))
-> Writer String (ProgramFile DA) -> (ProgramFile DA, String)
forall a b. (a -> b) -> a -> b
$ SpecParser DDTParseError DDTStatement
-> (SrcSpan
    -> SpecParseError DDTParseError -> WriterT String Identity ())
-> ProgramFile DA
-> Writer String (ProgramFile DA)
forall (m :: * -> *) e a ast.
(Monad m, Data a, Linkable a, ASTEmbeddable a ast) =>
SpecParser e ast
-> (SrcSpan -> SpecParseError e -> m ())
-> ProgramFile a
-> m (ProgramFile a)
annotateComments SpecParser DDTParseError DDTStatement
ddtParser
       (\ SrcSpan
srcSpan SpecParseError DDTParseError
err -> String -> WriterT String Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (String -> WriterT String Identity ())
-> String -> WriterT String Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Error " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcSpan -> String
forall a. Show a => a -> String
show SrcSpan
srcSpan String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SpecParseError DDTParseError -> String
forall a. Show a => a -> String
show SpecParseError DDTParseError
err) ProgramFile DA
pf''

     -- Attempt to gather any constant-expression information from indices.
     perArray :: [F.Index DA] -> [(Int, Maybe Int)]
     perArray :: [Index DA] -> [(Int, Maybe Int)]
perArray [Index DA]
is = [ (Int
n, do F.IxSingle DA
_ SrcSpan
_ Maybe String
Nothing Expression DA
e <- Index DA -> Maybe (Index DA)
forall a. a -> Maybe a
Just Index DA
ix
                            FAD.ConstInt Integer
i           <- DA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
FA.constExp (Expression DA -> DA
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression DA
e)
                            Int -> Maybe Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i))
                   | (Int
n, Index DA
ix) <- [Int] -> [Index DA] -> [(Int, Index DA)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Index DA]
is ]

     -- Gathered array information for each observed array access:
     accessInfo :: [(F.Name, IM.IntMap (S.Set (Maybe Int)))]
     accessInfo :: [(String, IntMap (Set (Maybe Int)))]
accessInfo = [ (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression DA
a, [(Int, Maybe Int)] -> IntMap (Set (Maybe Int))
forall b. Ord b => [(Int, b)] -> IntMap (Set b)
makeIntMapSet [(Int, Maybe Int)]
observation)
                  | F.ExpSubscript DA
_ SrcSpan
_ a :: Expression DA
a@(F.ExpValue DA
_ SrcSpan
_ (F.ValVariable String
_)) AList Index DA
is <- ProgramFile DA -> [Expression DA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile DA
pf''
                  , let observation :: [(Int, Maybe Int)]
observation = [Index DA] -> [(Int, Maybe Int)]
perArray ([Index DA] -> [(Int, Maybe Int)])
-> [Index DA] -> [(Int, Maybe Int)]
forall a b. (a -> b) -> a -> b
$ AList Index DA -> [Index DA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Index DA
is ]

     -- Convert access info into a map of information about the
     -- constants used to index arrays.
     amap :: M.Map F.Name (IM.IntMap (S.Set (Maybe Int)))
     amap :: AMap
amap = (IntMap (Set (Maybe Int))
 -> IntMap (Set (Maybe Int)) -> IntMap (Set (Maybe Int)))
-> [(String, IntMap (Set (Maybe Int)))] -> AMap
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith ((Set (Maybe Int) -> Set (Maybe Int) -> Set (Maybe Int))
-> IntMap (Set (Maybe Int))
-> IntMap (Set (Maybe Int))
-> IntMap (Set (Maybe Int))
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith Set (Maybe Int) -> Set (Maybe Int) -> Set (Maybe Int)
forall a. Ord a => Set a -> Set a -> Set a
S.union) [(String, IntMap (Set (Maybe Int)))]
accessInfo

     -- Filter only the interesting ones: at least one of the
     -- parameters was populated only by a range of constants where
     -- each constant is no more than 3 away from the adjacent ones.
     amap' :: AMap
amap' = (IntMap (Set (Maybe Int)) -> Bool) -> AMap -> AMap
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (IntMap (Set (Maybe Int)) -> Bool)
-> IntMap (Set (Maybe Int))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (Set (Maybe Int)) -> Bool
forall a. IntMap a -> Bool
IM.null (IntMap (Set (Maybe Int)) -> Bool)
-> (IntMap (Set (Maybe Int)) -> IntMap (Set (Maybe Int)))
-> IntMap (Set (Maybe Int))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (Maybe Int) -> Bool)
-> IntMap (Set (Maybe Int)) -> IntMap (Set (Maybe Int))
forall a. (a -> Bool) -> IntMap a -> IntMap a
IM.filter Set (Maybe Int) -> Bool
valid) AMap
amap -- accept if at least one valid parameter
       where
         diffs :: [Int] -> [Int]
diffs = ([Int] -> [Int] -> [Int]) -> ([Int], [Int]) -> [Int]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract) (([Int], [Int]) -> [Int])
-> ([Int] -> ([Int], [Int])) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Int]
forall a. a -> a
id ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> ([Int], [Int])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1) ([Int] -> ([Int], [Int]))
-> ([Int] -> [Int]) -> [Int] -> ([Int], [Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort -- compute differences between consecutive numbers
         -- valid set if...
         valid :: Set (Maybe Int) -> Bool
valid = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> (Set (Maybe Int) -> [Bool]) -> Set (Maybe Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Maybe Int] -> Bool] -> [Maybe Int] -> [Bool]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Bool -> Bool
not (Bool -> Bool) -> ([Maybe Int] -> Bool) -> [Maybe Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null                       -- (1) non-empty list
                                , (Maybe Int -> Bool) -> [Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust                       -- (2) of constants only, no wildcards
                                , (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3) ([Int] -> Bool) -> ([Maybe Int] -> [Int]) -> [Maybe Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
diffs ([Int] -> [Int]) -> ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Int -> Int) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust -- (3) no more than 3 away from adjacent constants
                                ] ([Maybe Int] -> [Bool])
-> (Set (Maybe Int) -> [Maybe Int]) -> Set (Maybe Int) -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Maybe Int) -> [Maybe Int]
forall a. Set a -> [a]
S.toList
--------------------------------------------------
-- Refactoring helpers

type RefactorM = RWS DerivedDataTypeReport [Essence] Bool

refactorPF :: DerivedDataTypeReport -> F.ProgramFile DA -> F.ProgramFile DA
refactorPF :: DerivedDataTypeReport -> ProgramFile DA -> ProgramFile DA
refactorPF DerivedDataTypeReport
r ProgramFile DA
pf = ProgramFile DA
pf'
  where
    -- FIXME: possibly use the 'essences' writer slot to instead
    -- gather derived-type declarations and put them somewhere
    -- central.
    (ProgramFile DA
pf', Bool
_, [Essence]
_) = RWS DerivedDataTypeReport [Essence] Bool (ProgramFile DA)
-> DerivedDataTypeReport
-> Bool
-> (ProgramFile DA, Bool, [Essence])
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS (([Block DA]
 -> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA])
-> ProgramFile DA
-> RWS DerivedDataTypeReport [Essence] Bool (ProgramFile DA)
forall from to (m :: * -> *).
(Biplate from to, Applicative m) =>
(to -> m to) -> from -> m from
descendBiM [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
refactorBlocks ProgramFile DA
pf) DerivedDataTypeReport
r Bool
False

refactorBlocks :: [F.Block DA] -> RefactorM [F.Block DA]
refactorBlocks :: [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
refactorBlocks = ([[Block DA]] -> [Block DA])
-> RWST DerivedDataTypeReport [Essence] Bool Identity [[Block DA]]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Block DA]] -> [Block DA]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (RWST DerivedDataTypeReport [Essence] Bool Identity [[Block DA]]
 -> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA])
-> ([Block DA]
    -> RWST DerivedDataTypeReport [Essence] Bool Identity [[Block DA]])
-> [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block DA
 -> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA])
-> [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [[Block DA]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block DA
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
refactorBlock

refactorBlock :: F.Block DA -> RefactorM [F.Block DA]
refactorBlock :: Block DA
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
refactorBlock Block DA
b = RWST
  DerivedDataTypeReport [Essence] Bool Identity DerivedDataTypeReport
forall r (m :: * -> *). MonadReader r m => m r
ask RWST
  DerivedDataTypeReport [Essence] Bool Identity DerivedDataTypeReport
-> (DerivedDataTypeReport
    -> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA])
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ DerivedDataTypeReport{Bool
[DDTStatement]
AMap
VMap
BadDimErrors
BadLabelErrors
SMap
Set IndexError
ddtrCheck :: Bool
ddtrBDE :: BadDimErrors
ddtrBLE :: BadLabelErrors
ddtrCE :: SMap
ddtrIDE :: Set IndexError
ddtrSpecs :: [DDTStatement]
ddtrSMap :: SMap
ddtrVMap :: VMap
ddtrAMap :: AMap
ddtrCheck :: DerivedDataTypeReport -> Bool
ddtrBDE :: DerivedDataTypeReport -> BadDimErrors
ddtrBLE :: DerivedDataTypeReport -> BadLabelErrors
ddtrCE :: DerivedDataTypeReport -> SMap
ddtrIDE :: DerivedDataTypeReport -> Set IndexError
ddtrSpecs :: DerivedDataTypeReport -> [DDTStatement]
ddtrSMap :: DerivedDataTypeReport -> SMap
ddtrVMap :: DerivedDataTypeReport -> VMap
ddtrAMap :: DerivedDataTypeReport -> AMap
..} -> case Block DA
b of
  -- Rewrite a type declaration of the variable to be converted into the new form.
  -- FIXME: handle references to other converted variables that are found in initialisation expressions
  F.BlStatement DA
a SrcSpan
ss Maybe (Expression DA)
lab (F.StDeclaration DA
stA SrcSpan
stSS TypeSpec DA
ty Maybe (AList Attribute DA)
attrs (F.AList DA
alA SrcSpan
alSS [Declarator DA]
decls)) -> do
    let declNames :: [(String, Declarator DA)]
declNames = (Declarator DA -> (String, Declarator DA))
-> [Declarator DA] -> [(String, Declarator DA)]
forall a b. (a -> b) -> [a] -> [b]
map ((Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName (Expression DA -> String)
-> (Declarator DA -> Expression DA) -> Declarator DA -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declarator DA -> Expression DA
forall a. Declarator a -> Expression a
declExp) (Declarator DA -> String)
-> (Declarator DA -> Declarator DA)
-> Declarator DA
-> (String, Declarator DA)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Declarator DA -> Declarator DA
forall a. a -> a
id) [Declarator DA]
decls
    -- Partition declared variables into 'refactor' and 'remain' sets.
    let ([(String, Declarator DA)]
declsRef, [(String, Declarator DA)]
declsRem) = ((String, Declarator DA) -> Bool)
-> [(String, Declarator DA)]
-> ([(String, Declarator DA)], [(String, Declarator DA)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((String -> AMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` AMap
ddtrAMap) (String -> Bool)
-> ((String, Declarator DA) -> String)
-> (String, Declarator DA)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Declarator DA) -> String
forall a b. (a, b) -> a
fst) [(String, Declarator DA)]
declNames
    let a' :: DA
a' | [(String, Declarator DA)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Declarator DA)]
declsRef = DA
a
           | Bool
otherwise     = ((A -> A) -> DA -> DA) -> DA -> (A -> A) -> DA
forall a b c. (a -> b -> c) -> b -> a -> c
flip (A -> A) -> DA -> DA
onOrigAnnotation DA
a ((A -> A) -> DA) -> (A -> A) -> DA
forall a b. (a -> b) -> a -> b
$ \ A
orig -> A
orig { refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just (SrcSpan -> Position
afterAligned SrcSpan
ss) }

    -- Process a variable (and its corresponding declaration).
    let eachVar :: (String, Declarator DA) -> [Block DA]
eachVar (String
var, Declarator DA
decl)
          | Just IntMap (Set (Maybe Int))
dimMap   <- String -> AMap -> Maybe (IntMap (Set (Maybe Int)))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
var AMap
ddtrAMap
            -- find the DimDecls for the array we are working on
          , [AList DimensionDeclarator DA]
dimDeclALists <- Block DA -> [AList DimensionDeclarator DA]
forall from to. Biplate from to => from -> [to]
universeBi Block DA
b :: [F.AList F.DimensionDeclarator DA]
          , Bool -> Bool
not ([AList DimensionDeclarator DA] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AList DimensionDeclarator DA]
dimDeclALists)
            -- if DimDecls are specified twice, take the last one:
          , F.AList DA
alDDA SrcSpan
alDDSS [DimensionDeclarator DA]
dimList <- [AList DimensionDeclarator DA] -> AList DimensionDeclarator DA
forall a. [a] -> a
last [AList DimensionDeclarator DA]
dimDeclALists
          , [Int]
dims          <- IntMap (Set (Maybe Int)) -> [Int]
forall a. IntMap a -> [Int]
IM.keys IntMap (Set (Maybe Int))
dimMap
          , Int
minDim        <- [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
dims
          , Int
maxDim        <- [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
dims
          , AList DimensionDeclarator DA
dimDeclAList' <- DA
-> SrcSpan
-> [DimensionDeclarator DA]
-> AList DimensionDeclarator DA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList DA
alDDA SrcSpan
alDDSS (Int -> [DimensionDeclarator DA] -> [DimensionDeclarator DA]
forall a. Int -> [a] -> [a]
take (Int
minDim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [DimensionDeclarator DA]
dimList)
          , [(Int, Set Essence)]
dimEssences   <- [(Int, Set Essence)] -> [(Int, Set Essence)]
forall a. Ord a => [a] -> [a]
sort ([(Int, Set Essence)] -> [(Int, Set Essence)])
-> [(Int, Set Essence)] -> [(Int, Set Essence)]
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe (Int, Set Essence)) -> [Int] -> [(Int, Set Essence)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ Int
dim -> (Int
dim,) (Set Essence -> (Int, Set Essence))
-> Maybe (Set Essence) -> Maybe (Int, Set Essence)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String, Int) -> SMap -> Maybe (Set Essence)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String
var, Int
dim) SMap
ddtrSMap) [Int]
dims
          , (Int
_, Set Essence
esset1):[(Int, Set Essence)]
_ <- [(Int, Set Essence)]
dimEssences
          , Essence
ess1:[Essence]
_        <- Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList Set Essence
esset1 =
          let
            F.TypeSpec DA
tyA SrcSpan
tySS BaseType
_ Maybe (Selector DA)
msel = TypeSpec DA
ty
            ty' :: TypeSpec DA
ty' = DA -> SrcSpan -> BaseType -> Maybe (Selector DA) -> TypeSpec DA
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
F.TypeSpec DA
tyA SrcSpan
tySS (String -> BaseType
F.TypeCustom (String -> BaseType) -> String -> BaseType
forall a b. (a -> b) -> a -> b
$ Essence -> String
essTypeName Essence
ess1) Maybe (Selector DA)
msel
            a'' :: DA
a'' = ((A -> A) -> DA -> DA) -> DA -> (A -> A) -> DA
forall a b c. (a -> b -> c) -> b -> a -> c
flip (A -> A) -> DA -> DA
onOrigAnnotation DA
a' ((A -> A) -> DA) -> (A -> A) -> DA
forall a b. (a -> b) -> a -> b
$ \ A
orig -> A
orig { newNode :: Bool
newNode = Bool
True }
            ss' :: SrcSpan
ss' = Position -> Position -> SrcSpan
FU.SrcSpan (Position -> Position
toCol0 Position
lp) Position
lp where lp :: Position
lp = SrcSpan -> Position
afterAligned SrcSpan
ss
            -- FIXME: character length, what to do
            decl' :: AList DimensionDeclarator DA -> Declarator DA
decl' AList DimensionDeclarator DA
ddAList
              | [DimensionDeclarator DA]
dds <- AList DimensionDeclarator DA -> [DimensionDeclarator DA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList DimensionDeclarator DA
ddAList
              , [DimensionDeclarator DA] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DimensionDeclarator DA]
dds  = DA
-> SrcSpan
-> Expression DA
-> Maybe (Expression DA)
-> Maybe (Expression DA)
-> Declarator DA
forall a.
a
-> SrcSpan
-> Expression a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.DeclVariable (Declarator DA -> DA
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Declarator DA
decl) (Declarator DA -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan Declarator DA
decl) (Declarator DA -> Expression DA
forall a. Declarator a -> Expression a
declExp Declarator DA
decl) Maybe (Expression DA)
forall a. Maybe a
Nothing Maybe (Expression DA)
forall a. Maybe a
Nothing
              | Bool
otherwise = DA
-> SrcSpan
-> Expression DA
-> AList DimensionDeclarator DA
-> Maybe (Expression DA)
-> Maybe (Expression DA)
-> Declarator DA
forall a.
a
-> SrcSpan
-> Expression a
-> AList DimensionDeclarator a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.DeclArray (Declarator DA -> DA
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Declarator DA
decl) (Declarator DA -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan Declarator DA
decl) (Declarator DA -> Expression DA
forall a. Declarator a -> Expression a
declExp Declarator DA
decl) AList DimensionDeclarator DA
ddAList Maybe (Expression DA)
forall a. Maybe a
Nothing Maybe (Expression DA)
forall a. Maybe a
Nothing

            -- The list of attributes minus any dimension attributes.
            attrs' :: Maybe (AList Attribute DA)
attrs' = ([Attribute DA] -> [Attribute DA])
-> Maybe (AList Attribute DA) -> Maybe (AList Attribute DA)
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi ((Attribute DA -> Bool) -> [Attribute DA] -> [Attribute DA]
forall a. (a -> Bool) -> [a] -> [a]
List.filter (Bool -> Bool
not (Bool -> Bool) -> (Attribute DA -> Bool) -> Attribute DA -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute DA -> Bool
isAttrDimension)) Maybe (AList Attribute DA)
attrs
            attrs'' :: Maybe (AList Attribute DA)
attrs'' | Just (F.AList DA
_ SrcSpan
_ []) <- Maybe (AList Attribute DA)
attrs' = Maybe (AList Attribute DA)
forall a. Maybe a
Nothing
                    | Bool
otherwise                       = Maybe (AList Attribute DA)
attrs'

            -- Each dimension index number along with its associated type-name.
            dimTypes :: [(Int, TypeSpec DA)]
dimTypes = (((Int, Set Essence) -> (Int, TypeSpec DA))
 -> [(Int, Set Essence)] -> [(Int, TypeSpec DA)])
-> [(Int, Set Essence)]
-> ((Int, Set Essence) -> (Int, TypeSpec DA))
-> [(Int, TypeSpec DA)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, Set Essence) -> (Int, TypeSpec DA))
-> [(Int, Set Essence)] -> [(Int, TypeSpec DA)]
forall a b. (a -> b) -> [a] -> [b]
map [(Int, Set Essence)]
dimEssences (((Int, Set Essence) -> (Int, TypeSpec DA))
 -> [(Int, TypeSpec DA)])
-> ((Set Essence -> TypeSpec DA)
    -> (Int, Set Essence) -> (Int, TypeSpec DA))
-> (Set Essence -> TypeSpec DA)
-> [(Int, TypeSpec DA)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Essence -> TypeSpec DA)
-> (Int, Set Essence) -> (Int, TypeSpec DA)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Set Essence -> TypeSpec DA) -> [(Int, TypeSpec DA)])
-> (Set Essence -> TypeSpec DA) -> [(Int, TypeSpec DA)]
forall a b. (a -> b) -> a -> b
$ \ Set Essence
esset -> case Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList Set Essence
esset of
              Essence{Bool
String
IntMap String
Set VInfo
essStarred :: Bool
essVInfoSet :: Set VInfo
essLabelMap :: IntMap String
essTypeName :: String
essStarred :: Essence -> Bool
essVInfoSet :: Essence -> Set VInfo
essLabelMap :: Essence -> IntMap String
essTypeName :: Essence -> String
..}:[Essence]
_ -> DA -> SrcSpan -> BaseType -> Maybe (Selector DA) -> TypeSpec DA
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
F.TypeSpec DA
tyA SrcSpan
tySS (String -> BaseType
F.TypeCustom (String -> BaseType) -> String -> BaseType
forall a b. (a -> b) -> a -> b
$ String
essTypeName) Maybe (Selector DA)
forall a. Maybe a
Nothing
              [Essence]
_ -> String -> TypeSpec DA
forall a. HasCallStack => String -> a
error String
"dimTypes: something broken badly: no essences in set"

            -- Process each dimension and return the AST-blocks that define the derived type.
            eachDim :: [F.DimensionDeclarator DA] -> Int -> [(Int, F.TypeSpec DA)] -> [F.Block DA]
            eachDim :: [DimensionDeclarator DA]
-> Int -> [(Int, TypeSpec DA)] -> [Block DA]
eachDim [DimensionDeclarator DA]
dimList' Int
maxDim' ((Int
dim, F.TypeSpec DA
_ SrcSpan
_ (F.TypeCustom String
tyName) Maybe (Selector DA)
_):(Int
_, TypeSpec DA
nextTy):[(Int, TypeSpec DA)]
rest)
              | Just (Essence{Bool
String
IntMap String
Set VInfo
essStarred :: Bool
essVInfoSet :: Set VInfo
essLabelMap :: IntMap String
essTypeName :: String
essStarred :: Essence -> Bool
essVInfoSet :: Essence -> Set VInfo
essLabelMap :: Essence -> IntMap String
essTypeName :: Essence -> String
..}:[Essence]
_) <- (Set Essence -> [Essence])
-> Maybe (Set Essence) -> Maybe [Essence]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList (Maybe (Set Essence) -> Maybe [Essence])
-> Maybe (Set Essence) -> Maybe [Essence]
forall a b. (a -> b) -> a -> b
$ (String, Int) -> SMap -> Maybe (Set Essence)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String
var, Int
dim) SMap
ddtrSMap = let
                  mInit :: Maybe (Expression DA)
mInit | [(Int, TypeSpec DA)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, TypeSpec DA)]
rest = Declarator DA -> Maybe (Expression DA)
forall a. Declarator a -> Maybe (Expression a)
declInitialiser Declarator DA
decl
                        | Bool
otherwise = Maybe (Expression DA)
forall a. Maybe a
Nothing
                  dimDeclAList :: AList DimensionDeclarator DA
dimDeclAList = DA
-> SrcSpan
-> [DimensionDeclarator DA]
-> AList DimensionDeclarator DA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList DA
a SrcSpan
ss ([DimensionDeclarator DA] -> AList DimensionDeclarator DA)
-> [DimensionDeclarator DA] -> AList DimensionDeclarator DA
forall a b. (a -> b) -> a -> b
$ Int -> [DimensionDeclarator DA] -> [DimensionDeclarator DA]
forall a. Int -> [a] -> [a]
drop Int
dim [DimensionDeclarator DA]
dimList'
                  eachLabel :: (a, String) -> Declarator DA
eachLabel (a
_, String
lab')
                    | Int
maxDim' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
dim Bool -> Bool -> Bool
&&
                      Int
dim Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [DimensionDeclarator DA] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DimensionDeclarator DA]
dimList' = DA
-> SrcSpan
-> Expression DA
-> AList DimensionDeclarator DA
-> Maybe (Expression DA)
-> Maybe (Expression DA)
-> Declarator DA
forall a.
a
-> SrcSpan
-> Expression a
-> AList DimensionDeclarator a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.DeclArray DA
a SrcSpan
ss (DA -> SrcSpan -> String -> Expression DA
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
FA.genVar DA
a SrcSpan
ss String
lab') AList DimensionDeclarator DA
dimDeclAList Maybe (Expression DA)
forall a. Maybe a
Nothing Maybe (Expression DA)
mInit
                    | Bool
otherwise             = DA
-> SrcSpan
-> Expression DA
-> Maybe (Expression DA)
-> Maybe (Expression DA)
-> Declarator DA
forall a.
a
-> SrcSpan
-> Expression a
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Declarator a
F.DeclVariable DA
a SrcSpan
ss (DA -> SrcSpan -> String -> Expression DA
forall a.
Analysis a -> SrcSpan -> String -> Expression (Analysis a)
FA.genVar DA
a SrcSpan
ss String
lab') Maybe (Expression DA)
forall a. Maybe a
Nothing Maybe (Expression DA)
mInit
                  labelDecls :: [Declarator DA]
labelDecls = ((Int, String) -> Declarator DA)
-> [(Int, String)] -> [Declarator DA]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> Declarator DA
forall a. (a, String) -> Declarator DA
eachLabel ([(Int, String)] -> [Declarator DA])
-> ([(Int, String)] -> [(Int, String)])
-> [(Int, String)]
-> [Declarator DA]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, String)] -> [(Int, String)]
forall a. Ord a => [a] -> [a]
sort ([(Int, String)] -> [Declarator DA])
-> [(Int, String)] -> [Declarator DA]
forall a b. (a -> b) -> a -> b
$ IntMap String -> [(Int, String)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap String
essLabelMap
                  in [ DA -> SrcSpan -> Maybe (Expression DA) -> Statement DA -> Block DA
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement DA
a'' SrcSpan
ss' Maybe (Expression DA)
forall a. Maybe a
Nothing (DA
-> SrcSpan -> Maybe (AList Attribute DA) -> String -> Statement DA
forall a.
a -> SrcSpan -> Maybe (AList Attribute a) -> String -> Statement a
F.StType DA
stA SrcSpan
stSS Maybe (AList Attribute DA)
forall a. Maybe a
Nothing String
tyName)
                     , DA -> SrcSpan -> Maybe (Expression DA) -> Statement DA -> Block DA
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement DA
a'' SrcSpan
ss' Maybe (Expression DA)
forall a. Maybe a
Nothing (DA
-> SrcSpan
-> TypeSpec DA
-> Maybe (AList Attribute DA)
-> AList Declarator DA
-> Statement DA
forall a.
a
-> SrcSpan
-> TypeSpec a
-> Maybe (AList Attribute a)
-> AList Declarator a
-> Statement a
F.StDeclaration DA
stA SrcSpan
stSS TypeSpec DA
nextTy Maybe (AList Attribute DA)
attrs'' (DA -> SrcSpan -> [Declarator DA] -> AList Declarator DA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList DA
alA SrcSpan
alSS [Declarator DA]
labelDecls))
                     , DA -> SrcSpan -> Maybe (Expression DA) -> Statement DA -> Block DA
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement DA
a'' SrcSpan
ss' Maybe (Expression DA)
forall a. Maybe a
Nothing (DA -> SrcSpan -> Maybe String -> Statement DA
forall a. a -> SrcSpan -> Maybe String -> Statement a
F.StEndType DA
stA SrcSpan
stSS Maybe String
forall a. Maybe a
Nothing) ]
            eachDim [DimensionDeclarator DA]
_ Int
_ [(Int, TypeSpec DA)]
_ = []
            in ([[Block DA]] -> [Block DA]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Block DA]] -> [Block DA])
-> ([[Block DA]] -> [[Block DA]]) -> [[Block DA]] -> [Block DA]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Block DA]] -> [[Block DA]]
forall a. [a] -> [a]
reverse ([[Block DA]] -> [Block DA]) -> [[Block DA]] -> [Block DA]
forall a b. (a -> b) -> a -> b
$ ([(Int, TypeSpec DA)] -> [Block DA])
-> [[(Int, TypeSpec DA)]] -> [[Block DA]]
forall a b. (a -> b) -> [a] -> [b]
map ([DimensionDeclarator DA]
-> Int -> [(Int, TypeSpec DA)] -> [Block DA]
eachDim [DimensionDeclarator DA]
dimList Int
maxDim) ([(Int, TypeSpec DA)] -> [[(Int, TypeSpec DA)]]
forall a. [a] -> [[a]]
List.tails ([(Int, TypeSpec DA)] -> [[(Int, TypeSpec DA)]])
-> [(Int, TypeSpec DA)] -> [[(Int, TypeSpec DA)]]
forall a b. (a -> b) -> a -> b
$ [(Int, TypeSpec DA)]
dimTypes [(Int, TypeSpec DA)]
-> [(Int, TypeSpec DA)] -> [(Int, TypeSpec DA)]
forall a. [a] -> [a] -> [a]
++ [(Int
0, TypeSpec DA
ty)])) [Block DA] -> [Block DA] -> [Block DA]
forall a. [a] -> [a] -> [a]
++
               -- The declaration of the variable under the new derived type:
               [DA -> SrcSpan -> Maybe (Expression DA) -> Statement DA -> Block DA
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement DA
a'' SrcSpan
ss' Maybe (Expression DA)
lab (DA
-> SrcSpan
-> TypeSpec DA
-> Maybe (AList Attribute DA)
-> AList Declarator DA
-> Statement DA
forall a.
a
-> SrcSpan
-> TypeSpec a
-> Maybe (AList Attribute a)
-> AList Declarator a
-> Statement a
F.StDeclaration DA
stA SrcSpan
stSS TypeSpec DA
ty' Maybe (AList Attribute DA)
attrs'' (DA -> SrcSpan -> [Declarator DA] -> AList Declarator DA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList DA
alA SrcSpan
alSS [AList DimensionDeclarator DA -> Declarator DA
decl' AList DimensionDeclarator DA
dimDeclAList']))]
          | Bool
otherwise = []

    let aRem :: DA
aRem = (A -> A) -> DA -> DA
onOrigAnnotation (\ A
orig -> A
orig { deleteNode :: Bool
deleteNode = [(String, Declarator DA)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Declarator DA)]
declsRem }) DA
a'
    [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Block DA]
 -> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA])
-> [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall a b. (a -> b) -> a -> b
$ -- Reinsert any other variables, with the refactored ones removed from the list.
             [DA -> SrcSpan -> Maybe (Expression DA) -> Statement DA -> Block DA
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
F.BlStatement DA
aRem SrcSpan
ss Maybe (Expression DA)
lab (DA
-> SrcSpan
-> TypeSpec DA
-> Maybe (AList Attribute DA)
-> AList Declarator DA
-> Statement DA
forall a.
a
-> SrcSpan
-> TypeSpec a
-> Maybe (AList Attribute a)
-> AList Declarator a
-> Statement a
F.StDeclaration DA
stA SrcSpan
stSS TypeSpec DA
ty Maybe (AList Attribute DA)
attrs (DA -> SrcSpan -> [Declarator DA] -> AList Declarator DA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList DA
alA SrcSpan
alSS (((String, Declarator DA) -> Declarator DA)
-> [(String, Declarator DA)] -> [Declarator DA]
forall a b. (a -> b) -> [a] -> [b]
map (String, Declarator DA) -> Declarator DA
forall a b. (a, b) -> b
snd [(String, Declarator DA)]
declsRem)))] [Block DA] -> [Block DA] -> [Block DA]
forall a. [a] -> [a] -> [a]
++
             -- Followed by the new set of declarations and derived types.
             ((String, Declarator DA) -> [Block DA])
-> [(String, Declarator DA)] -> [Block DA]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, Declarator DA) -> [Block DA]
eachVar [(String, Declarator DA)]
declsRef

  -- Eliminate comments that were processed.
  F.BlComment DA
a SrcSpan
ss Comment DA
_
    | Just DDTStatement
spec <- DDTAnnotation -> Maybe DDTStatement
ddtSpec (DA -> DDTAnnotation
forall a. Analysis a -> a
FA.prevAnnotation DA
a)
    , DDTStatement -> Bool
ddtStStarred DDTStatement
spec -> do
        let FU.SrcSpan Position
lp Position
_ = SrcSpan
ss
            ss' :: SrcSpan
ss' = SrcSpan -> SrcSpan
deleteLine SrcSpan
ss
            a' :: DA
a'  = ((A -> A) -> DA -> DA) -> DA -> (A -> A) -> DA
forall a b c. (a -> b -> c) -> b -> a -> c
flip (A -> A) -> DA -> DA
onOrigAnnotation DA
a ((A -> A) -> DA) -> (A -> A) -> DA
forall a b. (a -> b) -> a -> b
$ \ A
orig -> A
orig { refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
lp, deleteNode :: Bool
deleteNode = Bool
True }
        [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Block DA]
 -> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA])
-> [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall a b. (a -> b) -> a -> b
$ if DDTStatement
spec DDTStatement -> [DDTStatement] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` [DDTStatement]
ddtrSpecs
                 then [DA -> SrcSpan -> Comment DA -> Block DA
forall a. a -> SrcSpan -> Comment a -> Block a
F.BlComment DA
a' SrcSpan
ss' (Comment DA -> Block DA) -> Comment DA -> Block DA
forall a b. (a -> b) -> a -> b
$ String -> Comment DA
forall a. String -> Comment a
F.Comment String
""]
                 else [Block DA
b]
  -- Rewrite references to the converted variable
  F.BlStatement DA
_ SrcSpan
_ Maybe (Expression DA)
_ Statement DA
_ -> do
    Bool -> RWST DerivedDataTypeReport [Essence] Bool Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Bool
False
    Block DA
b'   <- (Expression DA
 -> RWST
      DerivedDataTypeReport [Essence] Bool Identity (Expression DA))
-> Block DA
-> RWST DerivedDataTypeReport [Essence] Bool Identity (Block DA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression DA
-> RWST
     DerivedDataTypeReport [Essence] Bool Identity (Expression DA)
refactorExp Block DA
b
    Bool
flag <- RWST DerivedDataTypeReport [Essence] Bool Identity Bool
forall s (m :: * -> *). MonadState s m => m s
get
    let FU.SrcSpan Position
lb Position
_ = Block DA -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan Block DA
b'
    if Bool
flag
      then [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall (m :: * -> *) a. Monad m => a -> m a
return [(DA -> DA) -> Block DA -> Block DA
forall (f :: * -> *) a. Annotated f => (a -> a) -> f a -> f a
F.modifyAnnotation ((A -> A) -> DA -> DA
onOrigAnnotation ((A -> A) -> DA -> DA) -> (A -> A) -> DA -> DA
forall a b. (a -> b) -> a -> b
$ \ A
a -> A
a { refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
lb }) Block DA
b']
      else [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall (m :: * -> *) a. Monad m => a -> m a
return [Block DA
b]
  -- FIXME: handle BlDo, etc
  Block DA
_ -> (Block DA -> [Block DA] -> [Block DA]
forall a. a -> [a] -> [a]
:[]) (Block DA -> [Block DA])
-> RWST DerivedDataTypeReport [Essence] Bool Identity (Block DA)
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Block DA]
 -> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA])
-> Block DA
-> RWST DerivedDataTypeReport [Essence] Bool Identity (Block DA)
forall from to (m :: * -> *).
(Biplate from to, Applicative m) =>
(to -> m to) -> from -> m from
descendBiM [Block DA]
-> RWST DerivedDataTypeReport [Essence] Bool Identity [Block DA]
refactorBlocks Block DA
b

isAttrDimension :: F.Attribute DA -> Bool
isAttrDimension :: Attribute DA -> Bool
isAttrDimension F.AttrDimension{} = Bool
True; isAttrDimension Attribute DA
_ = Bool
False

-- | Convert references such as @x(1,2,3)@ into @x % label1 % label2(3)@.
refactorExp :: F.Expression DA -> RefactorM (F.Expression DA)
refactorExp :: Expression DA
-> RWST
     DerivedDataTypeReport [Essence] Bool Identity (Expression DA)
refactorExp Expression DA
e = do
  SMap
smap <- (DerivedDataTypeReport -> SMap)
-> RWST DerivedDataTypeReport [Essence] Bool Identity SMap
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DerivedDataTypeReport -> SMap
ddtrSMap
  case Expression DA
e of
    F.ExpSubscript DA
a SrcSpan
s Expression DA
e1 AList Index DA
ixAList
      | [Index DA]
ixs   <- AList Index DA -> [Index DA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Index DA
ixAList
      , [Either (Index DA) (DA, SrcSpan, String)]
list  <- (Int -> Index DA -> Either (Index DA) (DA, SrcSpan, String))
-> [Int] -> [Index DA] -> [Either (Index DA) (DA, SrcSpan, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Index DA -> Either (Index DA) (DA, SrcSpan, String)
forall a.
Int
-> Index (Analysis a)
-> Either (Index (Analysis a)) (Analysis a, SrcSpan, String)
ixLookup [Int
1..] [Index DA]
ixs
      , (Either (Index DA) (DA, SrcSpan, String) -> Bool)
-> [Either (Index DA) (DA, SrcSpan, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either (Index DA) (DA, SrcSpan, String) -> Bool
forall a b. Either a b -> Bool
SE.isRight [Either (Index DA) (DA, SrcSpan, String)]
list
      , [[Either (Index DA) (DA, SrcSpan, String)]]
list' <- (Either (Index DA) (DA, SrcSpan, String)
 -> Either (Index DA) (DA, SrcSpan, String) -> Bool)
-> [Either (Index DA) (DA, SrcSpan, String)]
-> [[Either (Index DA) (DA, SrcSpan, String)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bool -> Bool -> Bool)
-> (Either (Index DA) (DA, SrcSpan, String) -> Bool)
-> Either (Index DA) (DA, SrcSpan, String)
-> Either (Index DA) (DA, SrcSpan, String)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Either (Index DA) (DA, SrcSpan, String) -> Bool
forall a b. Either a b -> Bool
SE.isLeft) [Either (Index DA) (DA, SrcSpan, String)]
list
      , Expression DA
e'    <- (Expression DA
 -> [Either (Index DA) (DA, SrcSpan, String)] -> Expression DA)
-> Expression DA
-> [[Either (Index DA) (DA, SrcSpan, String)]]
-> Expression DA
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Expression DA
-> [Either (Index DA) (DA, SrcSpan, String)] -> Expression DA
forall a b.
Expression DA
-> [Either (Index DA) (a, b, String)] -> Expression DA
rewrite Expression DA
e1 [[Either (Index DA) (DA, SrcSpan, String)]]
list'             -> Bool -> RWST DerivedDataTypeReport [Essence] Bool Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Bool
True RWST DerivedDataTypeReport [Essence] Bool Identity ()
-> RWST
     DerivedDataTypeReport [Essence] Bool Identity (Expression DA)
-> RWST
     DerivedDataTypeReport [Essence] Bool Identity (Expression DA)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expression DA
-> RWST
     DerivedDataTypeReport [Essence] Bool Identity (Expression DA)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression DA
e'
        where
          ixLookup :: Int
-> Index (Analysis a)
-> Either (Index (Analysis a)) (Analysis a, SrcSpan, String)
ixLookup Int
dim (F.IxSingle Analysis a
ixA SrcSpan
ixS Maybe String
Nothing Expression (Analysis a)
eIdx)
            | Just (FAD.ConstInt Integer
i) <- Analysis a -> Maybe Constant
forall a. Analysis a -> Maybe Constant
FA.constExp (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression (Analysis a)
eIdx)
            , Just (Essence{Bool
String
IntMap String
Set VInfo
essStarred :: Bool
essVInfoSet :: Set VInfo
essLabelMap :: IntMap String
essTypeName :: String
essStarred :: Essence -> Bool
essVInfoSet :: Essence -> Set VInfo
essLabelMap :: Essence -> IntMap String
essTypeName :: Essence -> String
..}:[Essence]
_)  <- (Set Essence -> [Essence])
-> Maybe (Set Essence) -> Maybe [Essence]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList (Maybe (Set Essence) -> Maybe [Essence])
-> Maybe (Set Essence) -> Maybe [Essence]
forall a b. (a -> b) -> a -> b
$ (String, Int) -> SMap -> Maybe (Set Essence)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression DA
e1, Int
dim) SMap
smap
            , Just String
label            <- Int -> IntMap String -> Maybe String
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i) IntMap String
essLabelMap = (Analysis a, SrcSpan, String)
-> Either (Index (Analysis a)) (Analysis a, SrcSpan, String)
forall a b. b -> Either a b
SE.Right (Analysis a
ixA, SrcSpan
ixS, String
label)
          ixLookup Int
_ Index (Analysis a)
ix = Index (Analysis a)
-> Either (Index (Analysis a)) (Analysis a, SrcSpan, String)
forall a b. a -> Either a b
SE.Left Index (Analysis a)
ix

          rewrite :: Expression DA
-> [Either (Index DA) (a, b, String)] -> Expression DA
rewrite Expression DA
e' l :: [Either (Index DA) (a, b, String)]
l@(SE.Left Index DA
_:[Either (Index DA) (a, b, String)]
_)              = DA -> SrcSpan -> Expression DA -> AList Index DA -> Expression DA
forall a.
a -> SrcSpan -> Expression a -> AList Index a -> Expression a
F.ExpSubscript DA
a SrcSpan
s Expression DA
e' (DA -> SrcSpan -> [Index DA] -> AList Index DA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList DA
a SrcSpan
s ([Index DA] -> AList Index DA) -> [Index DA] -> AList Index DA
forall a b. (a -> b) -> a -> b
$ (Either (Index DA) (a, b, String) -> Index DA)
-> [Either (Index DA) (a, b, String)] -> [Index DA]
forall a b. (a -> b) -> [a] -> [b]
map Either (Index DA) (a, b, String) -> Index DA
forall a b. Either a b -> a
SE.fromLeft [Either (Index DA) (a, b, String)]
l)
          rewrite Expression DA
e' (SE.Right (a
_, b
_, String
label):[Either (Index DA) (a, b, String)]
l)   = Expression DA
-> [Either (Index DA) (a, b, String)] -> Expression DA
rewrite (DA -> SrcSpan -> Expression DA -> Expression DA -> Expression DA
forall a.
a -> SrcSpan -> Expression a -> Expression a -> Expression a
F.ExpDataRef DA
a SrcSpan
s Expression DA
e' (DA -> SrcSpan -> Value DA -> Expression DA
forall a. a -> SrcSpan -> Value a -> Expression a
F.ExpValue DA
a SrcSpan
s (String -> Value DA
forall a. String -> Value a
F.ValVariable String
label))) [Either (Index DA) (a, b, String)]
l
          rewrite Expression DA
e' []                           = Expression DA
e'
    -- FIXME: either convert array slices, or regard that as a disqualifying effect
    Expression DA
_ -> Expression DA
-> RWST
     DerivedDataTypeReport [Essence] Bool Identity (Expression DA)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression DA
e

--------------------------------------------------
-- Synthesis helpers

-- Operate on [Block], handling insertion or deletion of blocks
synthBlocks :: (F.MetaInfo, Char) -> DerivedDataTypeReport -> [F.Block DA] -> [F.Block DA]
synthBlocks :: (MetaInfo, Char)
-> DerivedDataTypeReport -> [Block DA] -> [Block DA]
synthBlocks (MetaInfo, Char)
marker DerivedDataTypeReport
report = (Block DA -> [Block DA]) -> [Block DA] -> [Block DA]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((MetaInfo, Char) -> DerivedDataTypeReport -> Block DA -> [Block DA]
synthBlock (MetaInfo, Char)
marker DerivedDataTypeReport
report)

-- Synthesise comments where needed, strip existing comment annotations.
synthBlock :: (F.MetaInfo, Char) -> DerivedDataTypeReport -> F.Block DA -> [F.Block DA]
synthBlock :: (MetaInfo, Char) -> DerivedDataTypeReport -> Block DA -> [Block DA]
synthBlock (MetaInfo
mi, Char
marker) r :: DerivedDataTypeReport
r@DerivedDataTypeReport { ddtrAMap :: DerivedDataTypeReport -> AMap
ddtrAMap = AMap
amap } Block DA
b = case Block DA
b of
  -- check if this declaration has variables of interest
  F.BlStatement DA
a SrcSpan
ss Maybe (Expression DA)
_ F.StDeclaration{} | [(String, String)]
vars <- Block DA -> [(String, String)]
forall from. Data from => from -> [(String, String)]
ofInterest Block DA
b -> [(String, String)] -> [Block DA]
genComment [(String, String)]
vars [Block DA] -> [Block DA] -> [Block DA]
forall a. [a] -> [a] -> [a]
++ [Block DA
b]
    where
      ofInterest :: from -> [(String, String)]
ofInterest from
b' = ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> AMap -> Bool) -> AMap -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> AMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member AMap
amap (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) ([(String, String)] -> [(String, String)])
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$
        [ (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression DA
e, Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.srcName Expression DA
e) | F.DeclVariable DA
_ SrcSpan
_ Expression DA
e Maybe (Expression DA)
_ Maybe (Expression DA)
_ <- from -> [Declarator DA]
forall from to. Biplate from to => from -> [to]
universeBi from
b' :: [F.Declarator DA] ] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++
        [ (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression DA
e, Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.srcName Expression DA
e) | F.DeclArray DA
_ SrcSpan
_ Expression DA
e AList DimensionDeclarator DA
_ Maybe (Expression DA)
_ Maybe (Expression DA)
_ <- from -> [Declarator DA]
forall from to. Biplate from to => from -> [to]
universeBi from
b' :: [F.Declarator DA] ]

      genComment :: [(String, String)] -> [Block DA]
genComment = ((String, String) -> Block DA) -> [(String, String)] -> [Block DA]
forall a b. (a -> b) -> [a] -> [b]
map (((String, String) -> Block DA)
 -> [(String, String)] -> [Block DA])
-> ((String, String) -> Block DA)
-> [(String, String)]
-> [Block DA]
forall a b. (a -> b) -> a -> b
$ \ (String, String)
var ->
        DA -> SrcSpan -> Comment DA -> Block DA
forall a. a -> SrcSpan -> Comment a -> Block a
F.BlComment DA
newA SrcSpan
newSS (Comment DA -> Block DA)
-> (String -> Comment DA) -> String -> Block DA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Comment DA
forall a. String -> Comment a
F.Comment (String -> Comment DA) -> ShowS -> String -> Comment DA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaInfo -> Int -> ShowS
buildCommentText MetaInfo
mi Int
space (String -> Block DA) -> String -> Block DA
forall a b. (a -> b) -> a -> b
$ Char
markerChar -> ShowS
forall a. a -> [a] -> [a]
:DerivedDataTypeReport -> (String, String) -> String
genCommentText DerivedDataTypeReport
r (String, String)
var

      -- Set the refactored flag for the reprinter.
      newA :: DA
newA  = (A -> A) -> DA -> DA
onOrigAnnotation (\ A
orig -> A
orig { refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
lp } ) DA
a

      newSS :: SrcSpan
newSS = Position -> Position -> SrcSpan
FU.SrcSpan (Position
lp {posColumn :: Int
FU.posColumn = Int
0}) (Position
lp {posColumn :: Int
FU.posColumn = Int
0})
      FU.SrcSpan Position
lp Position
_ = SrcSpan
ss
      space :: Int
space = Position -> Int
FU.posColumn Position
lp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  -- strip existing comment annotations
  F.BlComment DA
a SrcSpan
ss Comment DA
_ | Maybe DDTStatement -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DDTStatement -> Bool)
-> (DA -> Maybe DDTStatement) -> DA -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DDTAnnotation -> Maybe DDTStatement
ddtSpec (DDTAnnotation -> Maybe DDTStatement)
-> (DA -> DDTAnnotation) -> DA -> Maybe DDTStatement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DA -> DDTAnnotation
forall a. Analysis a -> a
FA.prevAnnotation (DA -> Bool) -> DA -> Bool
forall a b. (a -> b) -> a -> b
$ DA
a -> [DA -> SrcSpan -> Comment DA -> Block DA
forall a. a -> SrcSpan -> Comment a -> Block a
F.BlComment DA
a' SrcSpan
ss' (Comment DA -> Block DA) -> Comment DA -> Block DA
forall a b. (a -> b) -> a -> b
$ String -> Comment DA
forall a. String -> Comment a
F.Comment String
""]
    where
      FU.SrcSpan Position
lp Position
_ = SrcSpan
ss
      ss' :: SrcSpan
ss' = SrcSpan -> SrcSpan
deleteLine SrcSpan
ss
      a' :: DA
a'  = ((A -> A) -> DA -> DA) -> DA -> (A -> A) -> DA
forall a b c. (a -> b -> c) -> b -> a -> c
flip (A -> A) -> DA -> DA
onOrigAnnotation DA
a ((A -> A) -> DA) -> (A -> A) -> DA
forall a b. (a -> b) -> a -> b
$ \ A
orig -> A
orig { refactored :: Maybe Position
refactored = Position -> Maybe Position
forall a. a -> Maybe a
Just Position
lp, deleteNode :: Bool
deleteNode = Bool
True }
  -- otherwise leave the Block untouched
  Block DA
_ -> [([Block DA] -> [Block DA]) -> Block DA -> Block DA
forall from to. Biplate from to => (to -> to) -> from -> from
descendBi ((MetaInfo, Char)
-> DerivedDataTypeReport -> [Block DA] -> [Block DA]
synthBlocks (MetaInfo
mi, Char
marker) DerivedDataTypeReport
r) Block DA
b]

-- Generate the text that goes into the specification.
genCommentText :: DerivedDataTypeReport -> (F.Name, F.Name) -> String
genCommentText :: DerivedDataTypeReport -> (String, String) -> String
genCommentText DerivedDataTypeReport{Bool
[DDTStatement]
AMap
VMap
BadDimErrors
BadLabelErrors
SMap
Set IndexError
ddtrCheck :: Bool
ddtrBDE :: BadDimErrors
ddtrBLE :: BadLabelErrors
ddtrCE :: SMap
ddtrIDE :: Set IndexError
ddtrSpecs :: [DDTStatement]
ddtrSMap :: SMap
ddtrVMap :: VMap
ddtrAMap :: AMap
ddtrCheck :: DerivedDataTypeReport -> Bool
ddtrBDE :: DerivedDataTypeReport -> BadDimErrors
ddtrBLE :: DerivedDataTypeReport -> BadLabelErrors
ddtrCE :: DerivedDataTypeReport -> SMap
ddtrIDE :: DerivedDataTypeReport -> Set IndexError
ddtrSpecs :: DerivedDataTypeReport -> [DDTStatement]
ddtrSMap :: DerivedDataTypeReport -> SMap
ddtrVMap :: DerivedDataTypeReport -> VMap
ddtrAMap :: DerivedDataTypeReport -> AMap
..} (String
varName, String
srcName)
  | Just IntMap (Set (Maybe Int))
pmap <- String -> AMap -> Maybe (IntMap (Set (Maybe Int)))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
varName AMap
ddtrAMap
  , (Int
dim, Set (Maybe Int)
set):[(Int, Set (Maybe Int))]
_ <- IntMap (Set (Maybe Int)) -> [(Int, Set (Maybe Int))]
forall a. IntMap a -> [(Int, a)]
IM.toList (IntMap (Set (Maybe Int)) -> [(Int, Set (Maybe Int))])
-> IntMap (Set (Maybe Int)) -> [(Int, Set (Maybe Int))]
forall a b. (a -> b) -> a -> b
$ (Set (Maybe Int) -> Bool)
-> IntMap (Set (Maybe Int)) -> IntMap (Set (Maybe Int))
forall a. (a -> Bool) -> IntMap a -> IntMap a
IM.filter ((Maybe Int -> Bool) -> [Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe Int] -> Bool)
-> (Set (Maybe Int) -> [Maybe Int]) -> Set (Maybe Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Maybe Int) -> [Maybe Int]
forall a. Set a -> [a]
S.toList) IntMap (Set (Maybe Int))
pmap =
    case (String, Int) -> SMap -> Maybe (Set Essence)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String
varName, Int
dim) SMap
ddtrSMap of
      -- generate new comment from scratch
      Maybe (Set Essence)
Nothing
        | [Int]
nums <- (Maybe Int -> Int) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Set (Maybe Int) -> [Maybe Int]
forall a. Set a -> [a]
S.toList Set (Maybe Int)
set
        , String
ty   <- String
varName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_type"
        , String
labs <- String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"label" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str | Int
num <- [Int]
nums, let str :: String
str = Int -> String
forall a. Show a => a -> String
show Int
num ] ->
            String
" ddt " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
labs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(dim=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dim String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
      -- generate comment from pre-existing info
      Just Set Essence
essenceSet
        | Essence{Bool
String
IntMap String
Set VInfo
essStarred :: Bool
essVInfoSet :: Set VInfo
essLabelMap :: IntMap String
essTypeName :: String
essStarred :: Essence -> Bool
essVInfoSet :: Essence -> Set VInfo
essLabelMap :: Essence -> IntMap String
essTypeName :: Essence -> String
..}:[Essence]
_ <- Set Essence -> [Essence]
forall a. Set a -> [a]
S.toList Set Essence
essenceSet
        , String
labs          <- String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " [ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lab | (Int
i, String
lab) <- IntMap String -> [(Int, String)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap String
essLabelMap ]
        , String
starStr       <- if Bool
essStarred then String
"* " else String
" " ->
            String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ddtShort String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
starStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
essTypeName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
labs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(dim=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
dim String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
      Maybe (Set Essence)
_ -> ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"genCommentText: unable to generate text for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
srcName
  | Bool
otherwise = ShowS
forall a. HasCallStack => String -> a
error ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"genCommentText: empty pmap entry and/or unable to lookup varName = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
varName

--------------------------------------------------
-- Check helpers

-- | From the given piece of AST, returns a list of declared variables
-- (unique form) paired with location.
declaredVars :: Data (f DA) => String -> f DA -> [(F.Name, VInfo)]
declaredVars :: String -> f DA -> [(String, VInfo)]
declaredVars String
srcFile f DA
x = [ (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression DA
e, String -> String -> SrcSpan -> VInfo
VInfo (Expression DA -> String
forall a. Expression (Analysis a) -> String
FA.srcName Expression DA
e) String
srcFile (Expression DA -> SrcSpan
forall a. Spanned a => a -> SrcSpan
FU.getSpan Expression DA
e)) | Expression DA
e <- f DA -> [Expression DA]
forall (f :: * -> *). Data (f DA) => f DA -> [Expression DA]
declaredExps f DA
x ]


-- | From the given piece of AST, returns a list of expressions
-- associated with the declarators.
declaredExps :: Data (f DA) => f DA -> [F.Expression DA]
declaredExps :: f DA -> [Expression DA]
declaredExps f DA
x = [ Expression DA
e | Declarator DA
d <- f DA -> [Declarator DA]
forall from to. Biplate from to => from -> [to]
universeBi f DA
x :: [F.Declarator DA]
                     , e :: Expression DA
e@(F.ExpValue DA
_ SrcSpan
_ (F.ValVariable String
_)) <- [Declarator DA -> Expression DA
forall a. Declarator a -> Expression a
declExp Declarator DA
d] ]


-- | Pattern matches the expression from the declarator
declExp :: F.Declarator a -> F.Expression a
declExp :: Declarator a -> Expression a
declExp (F.DeclVariable a
_ SrcSpan
_ Expression a
e Maybe (Expression a)
_ Maybe (Expression a)
_) = Expression a
e
declExp (F.DeclArray a
_ SrcSpan
_ Expression a
e AList DimensionDeclarator a
_ Maybe (Expression a)
_ Maybe (Expression a)
_)  = Expression a
e

-- | Pattern matches the initialiser from the declarator
declInitialiser :: F.Declarator a -> Maybe (F.Expression a)
declInitialiser :: Declarator a -> Maybe (Expression a)
declInitialiser (F.DeclVariable a
_ SrcSpan
_ Expression a
_ Maybe (Expression a)
_ Maybe (Expression a)
me) = Maybe (Expression a)
me
declInitialiser (F.DeclArray a
_ SrcSpan
_ Expression a
_ AList DimensionDeclarator a
_ Maybe (Expression a)
_ Maybe (Expression a)
me)  = Maybe (Expression a)
me

-- | Given a parsed specification and variable information, attempts
-- to 'distil' the essence of the specification. If there is a problem
-- with the spec then it returns SE.Left, otherwise SE.Right.
distil :: DDTStatement -> VInfo -> SE.Either IndexError Essence
distil :: DDTStatement -> VInfo -> Either IndexError Essence
distil (DDTSt { ddtStStarred :: DDTStatement -> Bool
ddtStStarred = Bool
star, ddtStTypeName :: DDTStatement -> String
ddtStTypeName = String
tyname, ddtStLabels :: DDTStatement -> [(String, String)]
ddtStLabels = [(String, String)]
labels }) VInfo
vinfo
  -- if no duplicated indices
  | [Int] -> Bool
forall a. Eq a => [a] -> Bool
noDups [Int]
nums = Essence -> Either IndexError Essence
forall a b. b -> Either a b
SE.Right (Essence -> Either IndexError Essence)
-> Essence -> Either IndexError Essence
forall a b. (a -> b) -> a -> b
$ Essence :: String -> IntMap String -> Set VInfo -> Bool -> Essence
Essence { essTypeName :: String
essTypeName = String
tyname
                                     , essLabelMap :: IntMap String
essLabelMap = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
n, String
lname) | (Int
n, String
lname) <- [(Int, String)]
labels' ]
                                     , essVInfoSet :: Set VInfo
essVInfoSet = VInfo -> Set VInfo
forall a. a -> Set a
S.singleton VInfo
vinfo
                                     , essStarred :: Bool
essStarred  = Bool
star }
  -- if there's a problem
  | Bool
otherwise   = IndexError -> Either IndexError Essence
forall a b. a -> Either a b
SE.Left (IndexError -> Either IndexError Essence)
-> IndexError -> Either IndexError Essence
forall a b. (a -> b) -> a -> b
$ String -> VInfo -> [Int] -> IndexError
IndexDupError String
tyname VInfo
vinfo ([Int]
nums [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ [Int] -> [Int]
forall a. Eq a => [a] -> [a]
List.nub [Int]
nums)
  where
    labels' :: [(Int, String)]
labels'   = ((String, String) -> (Int, String))
-> [(String, String)] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Int) -> (String, String) -> (Int, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> Int
forall a. Read a => String -> a
read) [(String, String)]
labels
    nums :: [Int]
nums      = ((Int, String) -> Int) -> [(Int, String)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> Int
forall a b. (a, b) -> a
fst [(Int, String)]
labels'
    noDups :: [a] -> Bool
noDups [a]
ns = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> [a]
forall a. Eq a => [a] -> [a]
List.nub [a]
ns) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ns

-- | Create an essence from array access information derived in a
-- file, assuming some default names and labels.
distilArrayInfo :: F.Name -> S.Set VInfo -> S.Set Int -> Essence
distilArrayInfo :: String -> Set VInfo -> Set Int -> Essence
distilArrayInfo String
var Set VInfo
essVInfoSet Set Int
dimSet = Essence :: String -> IntMap String -> Set VInfo -> Bool -> Essence
Essence{Bool
String
IntMap String
Set VInfo
essStarred :: Bool
essLabelMap :: IntMap String
essTypeName :: String
essVInfoSet :: Set VInfo
essStarred :: Bool
essVInfoSet :: Set VInfo
essLabelMap :: IntMap String
essTypeName :: String
..}
  where
    essTypeName :: String
essTypeName = String
var String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_type"
    essLabelMap :: IntMap String
essLabelMap = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IM.fromList [ (Int
n, String
lname) | Int
n <- Set Int -> [Int]
forall a. Set a -> [a]
S.toList Set Int
dimSet, let lname :: String
lname = String
"label" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n ]
    essStarred :: Bool
essStarred  = Bool
False

-- | Like concatMap, over Sets
setConcatMap :: (Ord a, Ord b) => (a -> [b]) -> S.Set a -> S.Set b
setConcatMap :: (a -> [b]) -> Set a -> Set b
setConcatMap a -> [b]
f = [b] -> Set b
forall a. Ord a => [a] -> Set a
S.fromList ([b] -> Set b) -> (Set a -> [b]) -> Set a -> Set b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [b]) -> [a] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [b]
f ([a] -> [b]) -> (Set a -> [a]) -> Set a -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
S.toList

-- | Turn a list of indexed pairs into an IntMap combining values into sets.
makeIntMapSet :: Ord b => [(Int, b)] -> IM.IntMap (S.Set b)
makeIntMapSet :: [(Int, b)] -> IntMap (Set b)
makeIntMapSet = (Set b -> Set b -> Set b) -> [(Int, Set b)] -> IntMap (Set b)
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
S.union ([(Int, Set b)] -> IntMap (Set b))
-> ([(Int, b)] -> [(Int, Set b)]) -> [(Int, b)] -> IntMap (Set b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, b) -> (Int, Set b)) -> [(Int, b)] -> [(Int, Set b)]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> Set b) -> (Int, b) -> (Int, Set b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second b -> Set b
forall a. a -> Set a
S.singleton)

-- | Operates like 'sequence' but on an IntMap.
sequenceIntMap :: Monad m => IM.IntMap (m a) -> m (IM.IntMap a)
sequenceIntMap :: IntMap (m a) -> m (IntMap a)
sequenceIntMap = ([(Int, a)] -> IntMap a) -> m [(Int, a)] -> m (IntMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IM.fromList (m [(Int, a)] -> m (IntMap a))
-> (IntMap (m a) -> m [(Int, a)]) -> IntMap (m a) -> m (IntMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [m (Int, a)] -> m [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([m (Int, a)] -> m [(Int, a)])
-> (IntMap (m a) -> [m (Int, a)]) -> IntMap (m a) -> m [(Int, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, m a) -> m (Int, a)) -> [(Int, m a)] -> [m (Int, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, m a) -> m (Int, a)
forall (f :: * -> *) a b. Functor f => (a, f b) -> f (a, b)
mstrength ([(Int, m a)] -> [m (Int, a)])
-> (IntMap (m a) -> [(Int, m a)]) -> IntMap (m a) -> [m (Int, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (m a) -> [(Int, m a)]
forall a. IntMap a -> [(Int, a)]
IM.toList

-- | Lifts the monad from the second half of the pair.
mstrength :: Functor f => (a, f b) -> f (a, b)
mstrength :: (a, f b) -> f (a, b)
mstrength (a
x, f b
my) = (b -> (a, b)) -> f b -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
x,) f b
my

--------------------------------------------------
-- Compilation helpers

-- | Generate a new ModFile containing derived datatype information.
genDDTModFile :: Data a => F.ProgramFile (FA.Analysis a) -> DerivedDataTypeReport -> ModFile
genDDTModFile :: ProgramFile (Analysis a) -> DerivedDataTypeReport -> ModFile
genDDTModFile ProgramFile (Analysis a)
pf DerivedDataTypeReport
ddtr = (Maybe ByteString -> Maybe ByteString)
-> String -> ModFile -> ModFile
alterModFileData Maybe ByteString -> Maybe ByteString
forall p. p -> Maybe ByteString
f String
ddtCompiledDataLabel (ModFile -> ModFile) -> ModFile -> ModFile
forall a b. (a -> b) -> a -> b
$ ProgramFile (Analysis a) -> ModFile
forall a. Data a => ProgramFile (Analysis a) -> ModFile
genModFile ProgramFile (Analysis a)
pf
  where
    f :: p -> Maybe ByteString
f p
_ = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ DerivedDataTypeReport -> ByteString
forall a. Binary a => a -> ByteString
encode DerivedDataTypeReport
ddtr

-- | Decode a DerivedDataTypeReport from a ModFile.
mfDerivedDataTypeReport :: ModFile -> DerivedDataTypeReport
mfDerivedDataTypeReport :: ModFile -> DerivedDataTypeReport
mfDerivedDataTypeReport ModFile
mf = case String -> ModFile -> Maybe ByteString
lookupModFileData String
ddtCompiledDataLabel ModFile
mf of
  Maybe ByteString
Nothing -> DerivedDataTypeReport
forall a. Monoid a => a
mempty
  Just ByteString
bs -> case ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, DerivedDataTypeReport)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs of
    Left (ByteString, ByteOffset, String)
_ -> DerivedDataTypeReport
forall a. Monoid a => a
mempty
    Right (ByteString
_, ByteOffset
_, DerivedDataTypeReport
ddtr) -> DerivedDataTypeReport
ddtr

-- | Combine all reports from ModFiles using (<>)
combinedDerivedDataTypeReport :: ModFiles -> DerivedDataTypeReport
combinedDerivedDataTypeReport :: ModFiles -> DerivedDataTypeReport
combinedDerivedDataTypeReport = (ModFile -> DerivedDataTypeReport)
-> ModFiles -> DerivedDataTypeReport
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ModFile -> DerivedDataTypeReport
mfDerivedDataTypeReport

-- | Section name for derived datatype info inside a ModFile.
ddtCompiledDataLabel :: String
ddtCompiledDataLabel :: String
ddtCompiledDataLabel = String
"derived-datatypes-compiled-data"