module Language.Fortran.Transformation.Grouping ( groupForall
                                                , groupDo
                                                , groupLabeledDo
                                                ) where

import Language.Fortran.AST
import Language.Fortran.Util.Position
import Language.Fortran.Analysis
import Language.Fortran.Transformation.TransformMonad

import Data.Data
import Data.List (intercalate)
import Data.Generics.Uniplate.Operations

type ABlocks a = [ Block (Analysis a) ]

genericGroup :: Data a => (ABlocks a -> ABlocks a) -> (Statement (Analysis a) -> Bool) -> Transform a ()
genericGroup :: forall a.
Data a =>
(ABlocks a -> ABlocks a)
-> (Statement (Analysis a) -> Bool) -> Transform a ()
genericGroup ABlocks a -> ABlocks a
groupingFunction Statement (Analysis a) -> Bool
checkingFunction = do
    ProgramFile (Analysis a)
pf <- Transform a (ProgramFile (Analysis a))
forall a. Transform a (ProgramFile (Analysis a))
getProgramFile
    let pf' :: ProgramFile (Analysis a)
pf' = (ABlocks a -> ABlocks a)
-> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ABlocks a -> ABlocks a
groupingFunction ProgramFile (Analysis a)
pf
        bad :: [Statement (Analysis a)]
bad = (Statement (Analysis a) -> Bool)
-> [Statement (Analysis a)] -> [Statement (Analysis a)]
forall a. (a -> Bool) -> [a] -> [a]
filter Statement (Analysis a) -> Bool
checkingFunction ([Statement (Analysis a)] -> [Statement (Analysis a)])
-> [Statement (Analysis a)] -> [Statement (Analysis a)]
forall a b. (a -> b) -> a -> b
$ ProgramFile (Analysis a) -> [Statement (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf'
    if [Statement (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Statement (Analysis a)]
bad
      then ProgramFile (Analysis a) -> Transform a ()
forall a. ProgramFile (Analysis a) -> Transform a ()
putProgramFile ProgramFile (Analysis a)
pf'
      else let spans :: [[Char]]
spans = [ Position -> [Char]
apparentFilePath Position
p1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
forall a. Show a => a -> [Char]
show SrcSpan
ss | Statement (Analysis a)
b <- [Statement (Analysis a)]
bad, let ss :: SrcSpan
ss@(SrcSpan Position
p1 Position
_) = Statement (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Statement (Analysis a)
b ] in
             [Char] -> Transform a ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> Transform a ()) -> [Char] -> Transform a ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Mis-matched grouping statements at these position(s): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
spans

--------------------------------------------------------------------------------
-- Grouping FORALL statement blocks into FORALL blocks in entire parse tree
--------------------------------------------------------------------------------
groupForall :: Data a => Transform a ()
groupForall :: forall a. Data a => Transform a ()
groupForall = (ABlocks a -> ABlocks a)
-> (Statement (Analysis a) -> Bool) -> Transform a ()
forall a.
Data a =>
(ABlocks a -> ABlocks a)
-> (Statement (Analysis a) -> Bool) -> Transform a ()
genericGroup ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupForall' Statement (Analysis a) -> Bool
forall a. Statement a -> Bool
isForall


groupForall' :: ABlocks a -> ABlocks a
groupForall' :: forall a. ABlocks a -> ABlocks a
groupForall' [] = []
groupForall' (Block (Analysis a)
b:[Block (Analysis a)]
bs) = Block (Analysis a)
b' Block (Analysis a) -> [Block (Analysis a)] -> [Block (Analysis a)]
forall a. a -> [a] -> [a]
: [Block (Analysis a)]
bs'
  where
    (Block (Analysis a)
b', [Block (Analysis a)]
bs') = case Block (Analysis a)
b of
      BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
label Statement (Analysis a)
st
        | StForall Analysis a
_ SrcSpan
_ Maybe [Char]
mTarget ForallHeader (Analysis a)
header <- Statement (Analysis a)
st ->
          let ( [Block (Analysis a)]
blocks, [Block (Analysis a)]
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel ) =
               [Block (Analysis a)]
-> Maybe [Char]
-> ([Block (Analysis a)], [Block (Analysis a)],
    Maybe (Expression (Analysis a)))
forall a.
ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonForallBlocks [Block (Analysis a)]
groupedBlocks Maybe [Char]
mTarget
          in ( Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> ForallHeader (Analysis a)
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> ForallHeader a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlForall Analysis a
a (SrcSpan -> [Block (Analysis a)] -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s [Block (Analysis a)]
blocks) Maybe (Expression (Analysis a))
label Maybe [Char]
mTarget ForallHeader (Analysis a)
header [Block (Analysis a)]
blocks Maybe (Expression (Analysis a))
endLabel
             , [Block (Analysis a)]
leftOverBlocks)
        | StForallStatement Analysis a
_ SrcSpan
_ ForallHeader (Analysis a)
header Statement (Analysis a)
st' <- Statement (Analysis a)
st ->
          let block :: Block (Analysis a)
block = Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Statement (Analysis a)
-> Block (Analysis a)
forall a.
a -> SrcSpan -> Maybe (Expression a) -> Statement a -> Block a
BlStatement Analysis a
a (Statement (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Statement (Analysis a)
st') Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing Statement (Analysis a)
st' in
          ( Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> ForallHeader (Analysis a)
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> ForallHeader a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlForall Analysis a
a (SrcSpan -> Statement (Analysis a) -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s Statement (Analysis a)
st') Maybe (Expression (Analysis a))
label Maybe [Char]
forall a. Maybe a
Nothing ForallHeader (Analysis a)
header [Block (Analysis a)
block] Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing, [Block (Analysis a)]
groupedBlocks )
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' ->
        ( ([Block (Analysis a)] -> [Block (Analysis a)])
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks [Block (Analysis a)] -> [Block (Analysis a)]
forall a. ABlocks a -> ABlocks a
groupForall' Block (Analysis a)
b'', [Block (Analysis a)]
groupedBlocks )
      Block (Analysis a)
_ -> (Block (Analysis a)
b, [Block (Analysis a)]
groupedBlocks)
    groupedBlocks :: [Block (Analysis a)]
groupedBlocks = [Block (Analysis a)] -> [Block (Analysis a)]
forall a. ABlocks a -> ABlocks a
groupForall' [Block (Analysis a)]
bs

collectNonForallBlocks :: ABlocks a -> Maybe String
                          -> ( ABlocks a
                             , ABlocks a
                             , Maybe (Expression (Analysis a)) )
collectNonForallBlocks :: forall a.
ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonForallBlocks ABlocks a
blocks Maybe [Char]
mNameTarget =
  case ABlocks a
blocks of
    BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mLabel (StEndForall Analysis a
_ SrcSpan
_ Maybe [Char]
mName):ABlocks a
rest
      | Maybe [Char]
mName Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Char]
mNameTarget -> ([], ABlocks a
rest, Maybe (Expression (Analysis a))
mLabel)
      | Bool
otherwise ->
        [Char] -> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
forall a. HasCallStack => [Char] -> a
error [Char]
"Forall block name does not match that of the end statement."
    Block (Analysis a)
b:ABlocks a
bs ->
      let (ABlocks a
bs', ABlocks a
rest, Maybe (Expression (Analysis a))
mLabel) = ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
forall a.
ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonForallBlocks ABlocks a
bs Maybe [Char]
mNameTarget
      in (Block (Analysis a)
b Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs', ABlocks a
rest, Maybe (Expression (Analysis a))
mLabel)
    ABlocks a
_ -> [Char] -> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
forall a. HasCallStack => [Char] -> a
error [Char]
"Premature file ending while parsing structured forall block."

isForall :: Statement a -> Bool
isForall :: forall a. Statement a -> Bool
isForall (StForall{}) = Bool
True
isForall (StForallStatement{}) = Bool
True
isForall Statement a
_ = Bool
False


--------------------------------------------------------------------------------
-- Grouping new do statement blocks into do blocks in entire parse tree
--------------------------------------------------------------------------------

groupDo :: Data a => Transform a ()
groupDo :: forall a. Data a => Transform a ()
groupDo = (ABlocks a -> ABlocks a)
-> (Statement (Analysis a) -> Bool) -> Transform a ()
forall a.
Data a =>
(ABlocks a -> ABlocks a)
-> (Statement (Analysis a) -> Bool) -> Transform a ()
genericGroup ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupDo' Statement (Analysis a) -> Bool
forall a. Statement a -> Bool
isDo

groupDo' :: ABlocks a -> ABlocks a
groupDo' :: forall a. ABlocks a -> ABlocks a
groupDo' [ ] = [ ]
groupDo' (Block (Analysis a)
b:[Block (Analysis a)]
bs) = Block (Analysis a)
b' Block (Analysis a) -> [Block (Analysis a)] -> [Block (Analysis a)]
forall a. a -> [a] -> [a]
: [Block (Analysis a)]
bs'
  where
    (Block (Analysis a)
b', [Block (Analysis a)]
bs') = case Block (Analysis a)
b of
      BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
label Statement (Analysis a)
st
        -- Do While statement
        | StDoWhile Analysis a
_ SrcSpan
_ Maybe [Char]
mTarget Maybe (Expression (Analysis a))
Nothing Expression (Analysis a)
condition <- Statement (Analysis a)
st ->
          let ( [Block (Analysis a)]
blocks, [Block (Analysis a)]
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel, Statement (Analysis a)
stEnd ) =
                [Block (Analysis a)]
-> Maybe [Char]
-> ([Block (Analysis a)], [Block (Analysis a)],
    Maybe (Expression (Analysis a)), Statement (Analysis a))
forall a.
ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)),
    Statement (Analysis a))
collectNonDoBlocks [Block (Analysis a)]
groupedBlocks Maybe [Char]
mTarget
          in ( Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDoWhile Analysis a
a (SrcSpan -> Statement (Analysis a) -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s Statement (Analysis a)
stEnd) Maybe (Expression (Analysis a))
label Maybe [Char]
mTarget Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing Expression (Analysis a)
condition [Block (Analysis a)]
blocks Maybe (Expression (Analysis a))
endLabel
             , [Block (Analysis a)]
leftOverBlocks)
        -- Vanilla do statement
        | StDo Analysis a
_ SrcSpan
_ Maybe [Char]
mName Maybe (Expression (Analysis a))
Nothing Maybe (DoSpecification (Analysis a))
doSpec <- Statement (Analysis a)
st ->
          let ( [Block (Analysis a)]
blocks, [Block (Analysis a)]
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel, Statement (Analysis a)
stEnd ) =
                [Block (Analysis a)]
-> Maybe [Char]
-> ([Block (Analysis a)], [Block (Analysis a)],
    Maybe (Expression (Analysis a)), Statement (Analysis a))
forall a.
ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)),
    Statement (Analysis a))
collectNonDoBlocks [Block (Analysis a)]
groupedBlocks Maybe [Char]
mName
          in ( Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> Maybe (Expression (Analysis a))
-> Maybe (DoSpecification (Analysis a))
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDo Analysis a
a (SrcSpan -> Statement (Analysis a) -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s Statement (Analysis a)
stEnd) Maybe (Expression (Analysis a))
label Maybe [Char]
mName Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing Maybe (DoSpecification (Analysis a))
doSpec [Block (Analysis a)]
blocks Maybe (Expression (Analysis a))
endLabel
             , [Block (Analysis a)]
leftOverBlocks)
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' ->
        ( ([Block (Analysis a)] -> [Block (Analysis a)])
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks [Block (Analysis a)] -> [Block (Analysis a)]
forall a. ABlocks a -> ABlocks a
groupDo' Block (Analysis a)
b'', [Block (Analysis a)]
groupedBlocks )
      Block (Analysis a)
_ -> ( Block (Analysis a)
b, [Block (Analysis a)]
groupedBlocks )
    groupedBlocks :: [Block (Analysis a)]
groupedBlocks = [Block (Analysis a)] -> [Block (Analysis a)]
forall a. ABlocks a -> ABlocks a
groupDo' [Block (Analysis a)]
bs -- Assume everything to the right is grouped.

collectNonDoBlocks :: ABlocks a -> Maybe String
                   -> ( ABlocks a
                      , ABlocks a
                      , Maybe (Expression (Analysis a))
                      , Statement (Analysis a) )
collectNonDoBlocks :: forall a.
ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)),
    Statement (Analysis a))
collectNonDoBlocks ABlocks a
blocks Maybe [Char]
mNameTarget =
  case ABlocks a
blocks of
    BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mLabel st :: Statement (Analysis a)
st@(StEnddo Analysis a
_ SrcSpan
_ Maybe [Char]
mName):ABlocks a
rest
      | Maybe [Char]
mName Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Char]
mNameTarget -> ([ ], ABlocks a
rest, Maybe (Expression (Analysis a))
mLabel, Statement (Analysis a)
st)
      | Bool
otherwise ->
          [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)),
    Statement (Analysis a))
forall a. HasCallStack => [Char] -> a
error [Char]
"Do block name does not match that of the end statement."
    Block (Analysis a)
b:ABlocks a
bs ->
      let (ABlocks a
bs', ABlocks a
rest, Maybe (Expression (Analysis a))
mLabel, Statement (Analysis a)
stEnd) = ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)),
    Statement (Analysis a))
forall a.
ABlocks a
-> Maybe [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)),
    Statement (Analysis a))
collectNonDoBlocks ABlocks a
bs Maybe [Char]
mNameTarget
      in (Block (Analysis a)
b Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs', ABlocks a
rest, Maybe (Expression (Analysis a))
mLabel, Statement (Analysis a)
stEnd)
    ABlocks a
_ -> [Char]
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)),
    Statement (Analysis a))
forall a. HasCallStack => [Char] -> a
error [Char]
"Premature file ending while parsing structured do block."

isDo :: Statement a -> Bool
isDo :: forall a. Statement a -> Bool
isDo Statement a
s = case Statement a
s of
  StDo a
_ SrcSpan
_ Maybe [Char]
_ Maybe (Expression a)
Nothing Maybe (DoSpecification a)
_      -> Bool
True
  StDoWhile a
_ SrcSpan
_ Maybe [Char]
_ Maybe (Expression a)
Nothing Expression a
_ -> Bool
True
  StEnddo{}                 -> Bool
True
  Statement a
_                         -> Bool
False

--------------------------------------------------------------------------------
-- Grouping labeled do statement blocks into do blocks in entire parse tree
--------------------------------------------------------------------------------

groupLabeledDo :: Data a => Transform a ()
groupLabeledDo :: forall a. Data a => Transform a ()
groupLabeledDo = (ABlocks a -> ABlocks a)
-> (Statement (Analysis a) -> Bool) -> Transform a ()
forall a.
Data a =>
(ABlocks a -> ABlocks a)
-> (Statement (Analysis a) -> Bool) -> Transform a ()
genericGroup ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupLabeledDo' Statement (Analysis a) -> Bool
forall a. Statement a -> Bool
isLabeledDo

groupLabeledDo' :: ABlocks a -> ABlocks a
groupLabeledDo' :: forall a. ABlocks a -> ABlocks a
groupLabeledDo' [ ] = [ ]
groupLabeledDo' (Block (Analysis a)
b:[Block (Analysis a)]
bs) = Block (Analysis a)
b' Block (Analysis a) -> [Block (Analysis a)] -> [Block (Analysis a)]
forall a. a -> [a] -> [a]
: [Block (Analysis a)]
bs'
  where
    (Block (Analysis a)
b', [Block (Analysis a)]
bs') = case Block (Analysis a)
b of
      BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
label
        (StDo Analysis a
_ SrcSpan
_ Maybe [Char]
mn tl :: Maybe (Expression (Analysis a))
tl@Just{} Maybe (DoSpecification (Analysis a))
doSpec) ->
          let ( [Block (Analysis a)]
blocks, [Block (Analysis a)]
leftOverBlocks, Maybe (Expression (Analysis a))
lastLabel ) =
                Maybe (Expression (Analysis a))
-> [Block (Analysis a)]
-> ([Block (Analysis a)], [Block (Analysis a)],
    Maybe (Expression (Analysis a)))
forall a.
Maybe (Expression (Analysis a))
-> ABlocks a
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonLabeledDoBlocks Maybe (Expression (Analysis a))
tl [Block (Analysis a)]
groupedBlocks
          in ( Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> Maybe (Expression (Analysis a))
-> Maybe (DoSpecification (Analysis a))
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDo Analysis a
a (SrcSpan -> [Block (Analysis a)] -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s [Block (Analysis a)]
blocks) Maybe (Expression (Analysis a))
label Maybe [Char]
mn Maybe (Expression (Analysis a))
tl Maybe (DoSpecification (Analysis a))
doSpec [Block (Analysis a)]
blocks Maybe (Expression (Analysis a))
lastLabel
             , [Block (Analysis a)]
leftOverBlocks )
      BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
label
        (StDoWhile Analysis a
_ SrcSpan
_ Maybe [Char]
mn tl :: Maybe (Expression (Analysis a))
tl@Just{} Expression (Analysis a)
cond) ->
          let ( [Block (Analysis a)]
blocks, [Block (Analysis a)]
leftOverBlocks, Maybe (Expression (Analysis a))
lastLabel ) =
                Maybe (Expression (Analysis a))
-> [Block (Analysis a)]
-> ([Block (Analysis a)], [Block (Analysis a)],
    Maybe (Expression (Analysis a)))
forall a.
Maybe (Expression (Analysis a))
-> ABlocks a
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonLabeledDoBlocks Maybe (Expression (Analysis a))
tl [Block (Analysis a)]
groupedBlocks
          in ( Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> [Block (Analysis a)]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDoWhile Analysis a
a (SrcSpan -> [Block (Analysis a)] -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s [Block (Analysis a)]
blocks) Maybe (Expression (Analysis a))
label Maybe [Char]
mn Maybe (Expression (Analysis a))
tl Expression (Analysis a)
cond [Block (Analysis a)]
blocks Maybe (Expression (Analysis a))
lastLabel
             , [Block (Analysis a)]
leftOverBlocks )
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' ->
        ( ([Block (Analysis a)] -> [Block (Analysis a)])
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks [Block (Analysis a)] -> [Block (Analysis a)]
forall a. ABlocks a -> ABlocks a
groupLabeledDo' Block (Analysis a)
b'', [Block (Analysis a)]
groupedBlocks )
      Block (Analysis a)
_ -> (Block (Analysis a)
b, [Block (Analysis a)]
groupedBlocks)

    -- Assume everything to the right is grouped.
    groupedBlocks :: [Block (Analysis a)]
groupedBlocks = [Block (Analysis a)] -> [Block (Analysis a)]
forall a. ABlocks a -> ABlocks a
groupLabeledDo' [Block (Analysis a)]
bs


collectNonLabeledDoBlocks :: Maybe (Expression (Analysis a)) -> ABlocks a
                          -> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonLabeledDoBlocks :: forall a.
Maybe (Expression (Analysis a))
-> ABlocks a
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonLabeledDoBlocks Maybe (Expression (Analysis a))
targetLabel ABlocks a
blocks =
  case ABlocks a
blocks of
    -- Didn't find a statement with matching label; don't group
    [] -> [Char] -> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
forall a. HasCallStack => [Char] -> a
error [Char]
"Malformed labeled DO group."
    Block (Analysis a)
b:ABlocks a
bs
      | Maybe (Expression (Analysis a))
-> Maybe (Expression (Analysis a)) -> Bool
forall a. Maybe (Expression a) -> Maybe (Expression a) -> Bool
compLabel (Block (Analysis a) -> Maybe (Expression (Analysis a))
forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLastLabel Block (Analysis a)
b) Maybe (Expression (Analysis a))
targetLabel -> (ABlocks a
b1, ABlocks a
bs, Block (Analysis a) -> Maybe (Expression (Analysis a))
forall (f :: * -> *) a. Labeled f => f a -> Maybe (Expression a)
getLastLabel Block (Analysis a)
b)
      | Bool
otherwise                              -> (Block (Analysis a)
b Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs', ABlocks a
rest, Maybe (Expression (Analysis a))
ll)
      where (ABlocks a
bs', ABlocks a
rest, Maybe (Expression (Analysis a))
ll) = Maybe (Expression (Analysis a))
-> ABlocks a
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
forall a.
Maybe (Expression (Analysis a))
-> ABlocks a
-> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonLabeledDoBlocks Maybe (Expression (Analysis a))
targetLabel ABlocks a
bs
            b1 :: ABlocks a
b1 = case Block (Analysis a)
b of BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StEnddo{}    -> []
                           BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StContinue{} -> []
                           Block (Analysis a)
_                              -> [Block (Analysis a)
b]


compLabel :: Maybe (Expression a) -> Maybe (Expression a) -> Bool
compLabel :: forall a. Maybe (Expression a) -> Maybe (Expression a) -> Bool
compLabel (Just (ExpValue a
_ SrcSpan
_ (ValInteger [Char]
l1 Maybe (Expression a)
_)))
          (Just (ExpValue a
_ SrcSpan
_ (ValInteger [Char]
l2 Maybe (Expression a)
_))) = [Char] -> [Char]
strip [Char]
l1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> [Char]
strip [Char]
l2
compLabel Maybe (Expression a)
_ Maybe (Expression a)
_ = Bool
False

strip :: String -> String
strip :: [Char] -> [Char]
strip = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'0')

isLabeledDo :: Statement a -> Bool
isLabeledDo :: forall a. Statement a -> Bool
isLabeledDo Statement a
s = case Statement a
s of
  StDo a
_ SrcSpan
_ Maybe [Char]
_ Just{} Maybe (DoSpecification a)
_       -> Bool
True
  StDoWhile a
_ SrcSpan
_ Maybe [Char]
_ Just{} Expression a
_  -> Bool
True
  Statement a
_                         -> Bool
False

--------------------------------------------------------------------------------
-- Helpers for grouping of structured blocks with more blocks inside.
--------------------------------------------------------------------------------

containsGroups :: Block (Analysis a) -> Bool
containsGroups :: forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b =
  case Block (Analysis a)
b of
    BlStatement{} -> Bool
False
    BlIf{}        -> Bool
True
    BlCase{}      -> Bool
True
    BlDo{}        -> Bool
True
    BlDoWhile{}   -> Bool
True
    BlInterface{} -> Bool
False
    BlComment{}   -> Bool
False
    BlForall{}    -> Bool
True
    BlAssociate{} -> Bool
True

applyGroupingToSubblocks :: (ABlocks a -> ABlocks a) -> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks :: forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks ABlocks a -> ABlocks a
f Block (Analysis a)
b
  | BlStatement{} <- Block (Analysis a)
b =
      [Char] -> Block (Analysis a)
forall a. HasCallStack => [Char] -> a
error [Char]
"Individual statements do not have subblocks. Must not occur."
  | BlIf Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
mn [Maybe (Expression (Analysis a))]
conds [ABlocks a]
blocks         Maybe (Expression (Analysis a))
el <- Block (Analysis a)
b =
    Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> [Maybe (Expression (Analysis a))]
-> [ABlocks a]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> [Maybe (Expression a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
BlIf Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
mn [Maybe (Expression (Analysis a))]
conds ((ABlocks a -> ABlocks a) -> [ABlocks a] -> [ABlocks a]
forall a b. (a -> b) -> [a] -> [b]
map ABlocks a -> ABlocks a
f [ABlocks a]
blocks) Maybe (Expression (Analysis a))
el
  | BlCase Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
mn Expression (Analysis a)
scrutinee [Maybe (AList Index (Analysis a))]
conds [ABlocks a]
blocks         Maybe (Expression (Analysis a))
el <- Block (Analysis a)
b =
    Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> Expression (Analysis a)
-> [Maybe (AList Index (Analysis a))]
-> [ABlocks a]
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> Expression a
-> [Maybe (AList Index a)]
-> [[Block a]]
-> Maybe (Expression a)
-> Block a
BlCase Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
mn Expression (Analysis a)
scrutinee [Maybe (AList Index (Analysis a))]
conds ((ABlocks a -> ABlocks a) -> [ABlocks a] -> [ABlocks a]
forall a b. (a -> b) -> [a] -> [b]
map ABlocks a -> ABlocks a
f [ABlocks a]
blocks) Maybe (Expression (Analysis a))
el
  | BlDo Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
n Maybe (Expression (Analysis a))
tl Maybe (DoSpecification (Analysis a))
doSpec ABlocks a
blocks     Maybe (Expression (Analysis a))
el <- Block (Analysis a)
b =
    Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> Maybe (Expression (Analysis a))
-> Maybe (DoSpecification (Analysis a))
-> ABlocks a
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> Maybe (Expression a)
-> Maybe (DoSpecification a)
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDo Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
n Maybe (Expression (Analysis a))
tl Maybe (DoSpecification (Analysis a))
doSpec (ABlocks a -> ABlocks a
f ABlocks a
blocks) Maybe (Expression (Analysis a))
el
  | BlDoWhile Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
n Maybe (Expression (Analysis a))
tl Expression (Analysis a)
doSpec ABlocks a
blocks     Maybe (Expression (Analysis a))
el <- Block (Analysis a)
b =
    Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> Maybe (Expression (Analysis a))
-> Expression (Analysis a)
-> ABlocks a
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> Maybe (Expression a)
-> Expression a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlDoWhile Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
l Maybe [Char]
n Maybe (Expression (Analysis a))
tl Expression (Analysis a)
doSpec (ABlocks a -> ABlocks a
f ABlocks a
blocks) Maybe (Expression (Analysis a))
el
  | BlInterface{} <- Block (Analysis a)
b =
      [Char] -> Block (Analysis a)
forall a. HasCallStack => [Char] -> a
error [Char]
"Interface blocks do not have groupable subblocks. Must not occur."
  | BlComment{} <- Block (Analysis a)
b =
      [Char] -> Block (Analysis a)
forall a. HasCallStack => [Char] -> a
error [Char]
"Comment statements do not have subblocks. Must not occur."
  | BlForall Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
ml Maybe [Char]
mn ForallHeader (Analysis a)
h ABlocks a
blocks Maybe (Expression (Analysis a))
mel <- Block (Analysis a)
b =
    Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> ForallHeader (Analysis a)
-> ABlocks a
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> ForallHeader a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlForall Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
ml Maybe [Char]
mn ForallHeader (Analysis a)
h (ABlocks a -> ABlocks a
f ABlocks a
blocks) Maybe (Expression (Analysis a))
mel
  | BlAssociate Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
ml Maybe [Char]
mn AList (ATuple Expression Expression) (Analysis a)
abbrevs ABlocks a
blocks     Maybe (Expression (Analysis a))
mel <- Block (Analysis a)
b =
    Analysis a
-> SrcSpan
-> Maybe (Expression (Analysis a))
-> Maybe [Char]
-> AList (ATuple Expression Expression) (Analysis a)
-> ABlocks a
-> Maybe (Expression (Analysis a))
-> Block (Analysis a)
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe [Char]
-> AList (ATuple Expression Expression) a
-> [Block a]
-> Maybe (Expression a)
-> Block a
BlAssociate Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
ml Maybe [Char]
mn AList (ATuple Expression Expression) (Analysis a)
abbrevs (ABlocks a -> ABlocks a
f ABlocks a
blocks) Maybe (Expression (Analysis a))
mel

--------------------------------------------------

-- Local variables:
-- mode: haskell
-- haskell-program-name: "cabal repl"
-- End: