module Language.Fortran.Transformation.Grouping ( groupForall
                                                , groupIf
                                                , groupDo
                                                , groupLabeledDo
                                                , groupCase
                                                ) 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 :: (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 :: 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' :: ABlocks a -> ABlocks a
groupForall' [] = []
groupForall' (Block (Analysis a)
b:ABlocks a
bs) = Block (Analysis a)
b' Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs'
  where
    (Block (Analysis a)
b', ABlocks 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 ( ABlocks a
blocks, ABlocks a
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel ) =
               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
groupedBlocks Maybe [Char]
mTarget
          in ( 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 -> ABlocks a -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s ABlocks a
blocks) Maybe (Expression (Analysis a))
label Maybe [Char]
mTarget ForallHeader (Analysis a)
header ABlocks a
blocks Maybe (Expression (Analysis a))
endLabel
             , ABlocks 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)
-> 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 -> 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, ABlocks a
groupedBlocks )
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' ->
        ( (ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupForall' Block (Analysis a)
b'', ABlocks a
groupedBlocks )
      Block (Analysis a)
_ -> (Block (Analysis a)
b, ABlocks a
groupedBlocks)
    groupedBlocks :: ABlocks a
groupedBlocks = ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupForall' ABlocks a
bs

collectNonForallBlocks :: ABlocks a -> Maybe String
                          -> ( ABlocks a
                             , ABlocks a
                             , Maybe (Expression (Analysis a)) )
collectNonForallBlocks :: 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 :: Statement a -> Bool
isForall (StForall{}) = Bool
True
isForall (StForallStatement{}) = Bool
True
isForall Statement a
_ = Bool
False

--------------------------------------------------------------------------------
-- Grouping if statement blocks into if blocks in entire parse tree
--------------------------------------------------------------------------------

groupIf :: Data a => Transform a ()
groupIf :: Transform a ()
groupIf = (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
groupIf' Statement (Analysis a) -> Bool
forall a. Statement a -> Bool
isIf

-- Actual grouping is done here.
-- 1. Case: head is a statement block with an IF statement:
-- 1.1  Group everything to the right of the statement.
-- 1.2  Prepend the head
-- 1.3  Decompose into if components (blocks and condition pairs).
-- 1.4  Using original if statement and decomposition artefacts synthesise a
--        structured if block.
-- 1.5  Prepend the block to the left over artefacts, which have already been
--        grouped in 1.1
-- 2. Case: head is a statement block containing any other statement:
-- 2.1  Group everything to the right and prepend the head.
groupIf' :: ABlocks a -> ABlocks a
groupIf' :: ABlocks a -> ABlocks a
groupIf' [] = []
groupIf' (Block (Analysis a)
b:ABlocks a
bs) = Block (Analysis a)
b' Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs'
  where
    (Block (Analysis a)
b', ABlocks a
bs') = case Block (Analysis a)
b of
      BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
label Statement (Analysis a)
st
        | StIfThen Analysis a
_ SrcSpan
_ Maybe [Char]
mName Expression (Analysis a)
_ <- Statement (Analysis a)
st -> -- If statement
          let ( [Maybe (Expression (Analysis a))]
conditions, [ABlocks a]
blocks, ABlocks a
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel, Statement (Analysis a)
endStmt ) =
                ABlocks a
-> ([Maybe (Expression (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)), Statement (Analysis a))
forall a.
ABlocks a
-> ([Maybe (Expression (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)), Statement (Analysis a))
decomposeIf (Block (Analysis a)
bBlock (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
:ABlocks a
groupedBlocks)
          in ( 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 -> Statement (Analysis a) -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s Statement (Analysis a)
endStmt) Maybe (Expression (Analysis a))
label Maybe [Char]
mName [Maybe (Expression (Analysis a))]
conditions [ABlocks a]
blocks Maybe (Expression (Analysis a))
endLabel
             , ABlocks a
leftOverBlocks)
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' -> -- Map to subblocks for groupable blocks
        ( (ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupIf' Block (Analysis a)
b'', ABlocks a
groupedBlocks )
      Block (Analysis a)
_ -> ( Block (Analysis a)
b, ABlocks a
groupedBlocks )
    groupedBlocks :: ABlocks a
groupedBlocks = ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupIf' ABlocks a
bs -- Assume everything to the right is grouped.

-- A program has the following structure:
--
--[ block... ]
-- if <condition> then
--   [ block... ]
-- else if <condition>
--   [ block... ]
-- else
--   [ block... ]
-- end if
-- [ block... ]
--
-- This function must only receive a list of blocks that start with if.
--
-- Internally it uses a more permissive breaking function that processes
-- individual (if-then, block), (else-if, block), and (else, block) pairs.
--
-- In that case it decomposes the block into list of (maybe) conditions and
-- blocks that those conditions correspond to. Additionally, it returns
-- whatever is after the if block.
decomposeIf :: ABlocks a
            -> ( [ Maybe (Expression (Analysis a)) ],
                 [ ABlocks a ],
                 ABlocks a,
                 Maybe (Expression (Analysis a)),
                 Statement (Analysis a) )
decomposeIf :: ABlocks a
-> ([Maybe (Expression (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)), Statement (Analysis a))
decomposeIf blocks :: ABlocks a
blocks@(BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (StIfThen Analysis a
_ SrcSpan
_ Maybe [Char]
mTargetName Expression (Analysis a)
_):ABlocks a
_) =
    ABlocks a
-> ([Maybe (Expression (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)), Statement (Analysis a))
forall a.
ABlocks a
-> ([Maybe (Expression (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)), Statement (Analysis a))
decomposeIf' ABlocks a
blocks
  where
    decomposeIf' :: [Block (Analysis a)]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
decomposeIf' (BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mLabel Statement (Analysis a)
st:[Block (Analysis a)]
rest) =
      case Statement (Analysis a)
st of
        StIfThen Analysis a
_ SrcSpan
_ Maybe [Char]
_ Expression (Analysis a)
condition -> Maybe (Expression (Analysis a))
-> [Block (Analysis a)]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
go (Expression (Analysis a) -> Maybe (Expression (Analysis a))
forall a. a -> Maybe a
Just Expression (Analysis a)
condition) [Block (Analysis a)]
rest
        StElsif Analysis a
_ SrcSpan
_ Maybe [Char]
_ Expression (Analysis a)
condition -> Maybe (Expression (Analysis a))
-> [Block (Analysis a)]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
go (Expression (Analysis a) -> Maybe (Expression (Analysis a))
forall a. a -> Maybe a
Just Expression (Analysis a)
condition) [Block (Analysis a)]
rest
        StElse{} -> Maybe (Expression (Analysis a))
-> [Block (Analysis a)]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
go Maybe (Expression (Analysis a))
forall a. Maybe a
Nothing [Block (Analysis a)]
rest
        StEndif Analysis a
_ SrcSpan
_ Maybe [Char]
mName
          | Maybe [Char]
mName Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Char]
mTargetName -> ([], [], [Block (Analysis a)]
rest, Maybe (Expression (Analysis a))
mLabel, Statement (Analysis a)
st)
          | Bool
otherwise -> [Char]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
     [Block (Analysis a)], Maybe (Expression (Analysis a)),
     Statement (Analysis a)))
-> [Char]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
forall a b. (a -> b) -> a -> b
$ [Char]
"If statement name does not match that of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                   [Char]
"the corresponding end if statement."
        Statement (Analysis a)
_ -> [Char]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
forall a. HasCallStack => [Char] -> a
error [Char]
"Block with non-if related statement. Should never occur."
    decomposeIf' [Block (Analysis a)]
_ = [Char]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
forall a. HasCallStack => [Char] -> a
error [Char]
"can't decompose block"
    go :: Maybe (Expression (Analysis a))
-> [Block (Analysis a)]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
go Maybe (Expression (Analysis a))
maybeCondition [Block (Analysis a)]
blocks' =
      let ([Block (Analysis a)]
nonConditionBlocks, [Block (Analysis a)]
rest') = [Block (Analysis a)]
-> ([Block (Analysis a)], [Block (Analysis a)])
forall a. ABlocks a -> (ABlocks a, ABlocks a)
collectNonConditionalBlocks [Block (Analysis a)]
blocks'
          ([Maybe (Expression (Analysis a))]
conditions, [[Block (Analysis a)]]
listOfBlocks, [Block (Analysis a)]
rest'', Maybe (Expression (Analysis a))
endLabel, Statement (Analysis a)
endStmt) = [Block (Analysis a)]
-> ([Maybe (Expression (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)),
    Statement (Analysis a))
decomposeIf' [Block (Analysis a)]
rest'
      in ( Maybe (Expression (Analysis a))
maybeCondition Maybe (Expression (Analysis a))
-> [Maybe (Expression (Analysis a))]
-> [Maybe (Expression (Analysis a))]
forall a. a -> [a] -> [a]
: [Maybe (Expression (Analysis a))]
conditions
         , [Block (Analysis a)]
nonConditionBlocks [Block (Analysis a)]
-> [[Block (Analysis a)]] -> [[Block (Analysis a)]]
forall a. a -> [a] -> [a]
: [[Block (Analysis a)]]
listOfBlocks
         , [Block (Analysis a)]
rest''
         , Maybe (Expression (Analysis a))
endLabel
         , Statement (Analysis a)
endStmt )
decomposeIf ABlocks a
_ = [Char]
-> ([Maybe (Expression (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)), Statement (Analysis a))
forall a. HasCallStack => [Char] -> a
error [Char]
"can't decompose block"

-- This compiles the executable blocks under various if conditions.
collectNonConditionalBlocks :: ABlocks a -> (ABlocks a, ABlocks a)
collectNonConditionalBlocks :: ABlocks a -> (ABlocks a, ABlocks a)
collectNonConditionalBlocks ABlocks a
blocks =
  case ABlocks a
blocks of
    BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StElsif{}:ABlocks a
_ -> ([], ABlocks a
blocks)
    BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StElse{}:ABlocks a
_ -> ([], ABlocks a
blocks)
    -- Here end block is included within the blocks unlike the other
    -- conditional directives. The reason is that this block can be
    -- a branch target if it is labeled according to the specification, hence
    -- it is presence in the parse tree is meaningful.
    BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ StEndif{}:ABlocks a
_ -> ([], ABlocks a
blocks)
    -- Catch all case for all non-if related blocks.
    Block (Analysis a)
b:ABlocks a
bs -> let (ABlocks a
bs', ABlocks a
rest) = ABlocks a -> (ABlocks a, ABlocks a)
forall a. ABlocks a -> (ABlocks a, ABlocks a)
collectNonConditionalBlocks ABlocks a
bs in (Block (Analysis a)
b Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs', ABlocks a
rest)
    -- In this case the structured if block is malformed and the file ends
    -- prematurely.
    ABlocks a
_ -> [Char] -> (ABlocks a, ABlocks a)
forall a. HasCallStack => [Char] -> a
error [Char]
"Premature file ending while parsing structured if block."

isIf :: Statement a -> Bool
isIf :: Statement a -> Bool
isIf Statement a
s = case Statement a
s of
  StIfThen{} -> Bool
True
  StElsif{}  -> Bool
True
  StElse{}   -> Bool
True
  StEndif{}  -> Bool
True
  Statement a
_          -> Bool
False

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

groupDo :: Data a => Transform a ()
groupDo :: 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' :: ABlocks a -> ABlocks a
groupDo' [ ] = [ ]
groupDo' (Block (Analysis a)
b:ABlocks a
bs) = Block (Analysis a)
b' Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs'
  where
    (Block (Analysis a)
b', ABlocks 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 ( ABlocks a
blocks, ABlocks a
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel, 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
groupedBlocks Maybe [Char]
mTarget
          in ( 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 -> 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 ABlocks a
blocks Maybe (Expression (Analysis a))
endLabel
             , ABlocks 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 ( ABlocks a
blocks, ABlocks a
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel, 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
groupedBlocks Maybe [Char]
mName
          in ( 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 -> 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 ABlocks a
blocks Maybe (Expression (Analysis a))
endLabel
             , ABlocks a
leftOverBlocks)
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' ->
        ( (ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupDo' Block (Analysis a)
b'', ABlocks a
groupedBlocks )
      Block (Analysis a)
_ -> ( Block (Analysis a)
b, ABlocks a
groupedBlocks )
    groupedBlocks :: ABlocks a
groupedBlocks = ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupDo' ABlocks 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 :: 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 :: 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 :: 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' :: ABlocks a -> ABlocks a
groupLabeledDo' [ ] = [ ]
groupLabeledDo' (Block (Analysis a)
b:ABlocks a
bs) = Block (Analysis a)
b' Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs'
  where
    (Block (Analysis a)
b', ABlocks 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 ( ABlocks a
blocks, ABlocks a
leftOverBlocks, Maybe (Expression (Analysis a))
lastLabel ) =
                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))
tl ABlocks a
groupedBlocks
          in ( 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 -> ABlocks a -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s ABlocks a
blocks) Maybe (Expression (Analysis a))
label Maybe [Char]
mn Maybe (Expression (Analysis a))
tl Maybe (DoSpecification (Analysis a))
doSpec ABlocks a
blocks Maybe (Expression (Analysis a))
lastLabel
             , ABlocks 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 ( ABlocks a
blocks, ABlocks a
leftOverBlocks, Maybe (Expression (Analysis a))
lastLabel ) =
                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))
tl ABlocks a
groupedBlocks
          in ( 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 -> ABlocks a -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s ABlocks a
blocks) Maybe (Expression (Analysis a))
label Maybe [Char]
mn Maybe (Expression (Analysis a))
tl Expression (Analysis a)
cond ABlocks a
blocks Maybe (Expression (Analysis a))
lastLabel
             , ABlocks a
leftOverBlocks )
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' ->
        ( (ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupLabeledDo' Block (Analysis a)
b'', ABlocks a
groupedBlocks )
      Block (Analysis a)
_ -> (Block (Analysis a)
b, ABlocks a
groupedBlocks)

    -- Assume everything to the right is grouped.
    groupedBlocks :: ABlocks a
groupedBlocks = ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupLabeledDo' ABlocks a
bs


collectNonLabeledDoBlocks :: Maybe (Expression (Analysis a)) -> ABlocks a
                          -> (ABlocks a, ABlocks a, Maybe (Expression (Analysis a)))
collectNonLabeledDoBlocks :: 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 :: Maybe (Expression a) -> Maybe (Expression a) -> Bool
compLabel (Just (ExpValue a
_ SrcSpan
_ (ValInteger [Char]
l1)))
          (Just (ExpValue a
_ SrcSpan
_ (ValInteger [Char]
l2))) = [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 :: 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

--------------------------------------------------------------------------------
-- Grouping case statements
--------------------------------------------------------------------------------

groupCase :: Data a => Transform a ()
groupCase :: Transform a ()
groupCase = (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
groupCase' Statement (Analysis a) -> Bool
forall a. Statement a -> Bool
isCase

groupCase' :: ABlocks a -> ABlocks a
groupCase' :: ABlocks a -> ABlocks a
groupCase' [] = []
groupCase' (Block (Analysis a)
b:ABlocks a
bs) = Block (Analysis a)
b' Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs'
  where
    (Block (Analysis a)
b', ABlocks a
bs') = case Block (Analysis a)
b of
      BlStatement Analysis a
a SrcSpan
s Maybe (Expression (Analysis a))
label Statement (Analysis a)
st
        | StSelectCase Analysis a
_ SrcSpan
_ Maybe [Char]
mName Expression (Analysis a)
scrutinee <- Statement (Analysis a)
st ->
          let blocksToDecomp :: ABlocks a
blocksToDecomp = (Block (Analysis a) -> Bool) -> ABlocks a -> ABlocks a
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Block (Analysis a) -> Bool
forall a. Block a -> Bool
isComment ABlocks a
groupedBlocks
              ( [Maybe (AList Index (Analysis a))]
conds, [ABlocks a]
blocks, ABlocks a
leftOverBlocks, Maybe (Expression (Analysis a))
endLabel ) = ABlocks a
-> Maybe [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a.
ABlocks a
-> Maybe [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
decomposeCase ABlocks a
blocksToDecomp Maybe [Char]
mName
          in ( 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 -> [ABlocks a] -> SrcSpan
forall a b. SpannedPair a b => a -> b -> SrcSpan
getTransSpan SrcSpan
s [ABlocks a]
blocks) Maybe (Expression (Analysis a))
label Maybe [Char]
mName Expression (Analysis a)
scrutinee [Maybe (AList Index (Analysis a))]
conds [ABlocks a]
blocks Maybe (Expression (Analysis a))
endLabel
             , ABlocks a
leftOverBlocks)
      Block (Analysis a)
b'' | Block (Analysis a) -> Bool
forall a. Block (Analysis a) -> Bool
containsGroups Block (Analysis a)
b'' -> -- Map to subblocks for groupable blocks
        ( (ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
forall a.
(ABlocks a -> ABlocks a)
-> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupCase' Block (Analysis a)
b'', ABlocks a
groupedBlocks )
      Block (Analysis a)
_ -> ( Block (Analysis a)
b , ABlocks a
groupedBlocks )
    groupedBlocks :: ABlocks a
groupedBlocks = ABlocks a -> ABlocks a
forall a. ABlocks a -> ABlocks a
groupCase' ABlocks a
bs -- Assume everything to the right is grouped.
    isComment :: Block a -> Bool
isComment Block a
b'' = case Block a
b'' of { BlComment{} -> Bool
True; Block a
_ -> Bool
False }

decomposeCase :: ABlocks a -> Maybe String
              -> ( [ Maybe (AList Index (Analysis a)) ]
                 , [ ABlocks a ]
                 , ABlocks a
                 , Maybe (Expression (Analysis a)) )
decomposeCase :: ABlocks a
-> Maybe [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
decomposeCase (BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mLabel Statement (Analysis a)
st:ABlocks a
rest) Maybe [Char]
mTargetName =
    case Statement (Analysis a)
st of
      StCase Analysis a
_ SrcSpan
_ Maybe [Char]
mName Maybe (AList Index (Analysis a))
mCondition
        | Maybe [Char]
Nothing <- Maybe [Char]
mName -> Maybe (AList Index (Analysis a))
-> ABlocks a
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a.
Maybe (AList Index (Analysis a))
-> [Block (Analysis a)]
-> ([Maybe (AList Index (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)))
go Maybe (AList Index (Analysis a))
mCondition ABlocks a
rest
        | Maybe [Char]
mName Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Char]
mTargetName -> Maybe (AList Index (Analysis a))
-> ABlocks a
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a.
Maybe (AList Index (Analysis a))
-> [Block (Analysis a)]
-> ([Maybe (AList Index (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)))
go Maybe (AList Index (Analysis a))
mCondition ABlocks a
rest
        | Bool
otherwise -> [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
     Maybe (Expression (Analysis a))))
-> [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a b. (a -> b) -> a -> b
$ [Char]
"Case name does not match that of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                 [Char]
"the corresponding select case statement."
      StEndcase Analysis a
_ SrcSpan
_ Maybe [Char]
mName
        | Maybe [Char]
mName Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe [Char]
mTargetName -> ([], [], ABlocks a
rest, Maybe (Expression (Analysis a))
mLabel)
        | Bool
otherwise -> [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a. HasCallStack => [Char] -> a
error ([Char]
 -> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
     Maybe (Expression (Analysis a))))
-> [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a b. (a -> b) -> a -> b
$ [Char]
"End case name does not match that of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                 [Char]
"the corresponding select case statement."
      Statement (Analysis a)
_ -> [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a. HasCallStack => [Char] -> a
error [Char]
"Block with non-case related statement. Must not occur."
  where
    go :: Maybe (AList Index (Analysis a))
-> [Block (Analysis a)]
-> ([Maybe (AList Index (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)))
go Maybe (AList Index (Analysis a))
mCondition [Block (Analysis a)]
blocks =
      let ([Block (Analysis a)]
nonCaseBlocks, [Block (Analysis a)]
rest') = [Block (Analysis a)]
-> ([Block (Analysis a)], [Block (Analysis a)])
forall a. ABlocks a -> (ABlocks a, ABlocks a)
collectNonCaseBlocks [Block (Analysis a)]
blocks
          ([Maybe (AList Index (Analysis a))]
conditions, [[Block (Analysis a)]]
listOfBlocks, [Block (Analysis a)]
rest'', Maybe (Expression (Analysis a))
endLabel) = [Block (Analysis a)]
-> Maybe [Char]
-> ([Maybe (AList Index (Analysis a))], [[Block (Analysis a)]],
    [Block (Analysis a)], Maybe (Expression (Analysis a)))
forall a.
ABlocks a
-> Maybe [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
decomposeCase [Block (Analysis a)]
rest' Maybe [Char]
mTargetName
      in ( Maybe (AList Index (Analysis a))
mCondition Maybe (AList Index (Analysis a))
-> [Maybe (AList Index (Analysis a))]
-> [Maybe (AList Index (Analysis a))]
forall a. a -> [a] -> [a]
: [Maybe (AList Index (Analysis a))]
conditions
         , [Block (Analysis a)]
nonCaseBlocks [Block (Analysis a)]
-> [[Block (Analysis a)]] -> [[Block (Analysis a)]]
forall a. a -> [a] -> [a]
: [[Block (Analysis a)]]
listOfBlocks
         , [Block (Analysis a)]
rest'', Maybe (Expression (Analysis a))
endLabel )
decomposeCase ABlocks a
_ Maybe [Char]
_ = [Char]
-> ([Maybe (AList Index (Analysis a))], [ABlocks a], ABlocks a,
    Maybe (Expression (Analysis a)))
forall a. HasCallStack => [Char] -> a
error [Char]
"can't decompose case"

-- This compiles the executable blocks under various if conditions.
collectNonCaseBlocks :: ABlocks a -> (ABlocks a, ABlocks a)
collectNonCaseBlocks :: ABlocks a -> (ABlocks a, ABlocks a)
collectNonCaseBlocks ABlocks a
blocks =
  case ABlocks a
blocks of
    BlStatement Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ Statement (Analysis a)
st:ABlocks a
_
      | StCase{} <- Statement (Analysis a)
st -> ( [], ABlocks a
blocks )
      | StEndcase{} <- Statement (Analysis a)
st -> ( [], ABlocks a
blocks )
    -- In this case case block is malformed and the file ends prematurely.
    Block (Analysis a)
b:ABlocks a
bs -> let (ABlocks a
bs', ABlocks a
rest) = ABlocks a -> (ABlocks a, ABlocks a)
forall a. ABlocks a -> (ABlocks a, ABlocks a)
collectNonCaseBlocks ABlocks a
bs in (Block (Analysis a)
b Block (Analysis a) -> ABlocks a -> ABlocks a
forall a. a -> [a] -> [a]
: ABlocks a
bs', ABlocks a
rest)
    ABlocks a
_ -> [Char] -> (ABlocks a, ABlocks a)
forall a. HasCallStack => [Char] -> a
error [Char]
"Premature file ending while parsing select case block."

isCase :: Statement a -> Bool
isCase :: Statement a -> Bool
isCase Statement a
s = case Statement a
s of
  StCase{}       -> Bool
True
  StEndcase{}    -> Bool
True
  StSelectCase{} -> Bool
True
  Statement a
_              -> Bool
False

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

containsGroups :: Block (Analysis a) -> Bool
containsGroups :: 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

applyGroupingToSubblocks :: (ABlocks a -> ABlocks a) -> Block (Analysis a) -> Block (Analysis a)
applyGroupingToSubblocks :: (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

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

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