feldspar-compiler-0.4.0.2: Feldspar/Compiler/Backend/C/Plugin/Locator.hs

{-# LANGUAGE TypeFamilies #-}

module Feldspar.Compiler.Backend.C.Plugin.Locator where

import Feldspar.Transformation
import Feldspar.Compiler.Backend.C.CodeGeneration
import Feldspar.Compiler.Backend.C.Plugin.PrettyPrint
import Feldspar.Compiler.Backend.C.Platforms
import Feldspar.Compiler.Backend.C.Options
import Feldspar.Compiler.Error


-- ===========================================================================
--  == GetPrg plugin
-- ===========================================================================


instance Default Bool where
    def = False

instance Default (Program DebugToCSemanticInfo) where
    def = Empty ((0,0),(0,0)) ((0,0),(0,0))

instance Combine Bool where
    combine l1 l2 = l1 || l2     

instance Combine (Program DebugToCSemanticInfo) where
    combine (Empty _ _) p2 = p2
    combine p1 _ = p1  

-----------------------------------------------------
--- GetPrg plugin for ParLoop
-----------------------------------------------------

data GetPrgParLoop = GetPrgParLoop

instance Transformation GetPrgParLoop where
    type From GetPrgParLoop    = DebugToCSemanticInfo
    type To GetPrgParLoop      = DebugToCSemanticInfo
    type Down GetPrgParLoop    = (Int, Int)  
    type Up GetPrgParLoop      = (Bool, Program DebugToCSemanticInfo)
    type State GetPrgParLoop   = ()


instance Plugin GetPrgParLoop where
    type ExternalInfo GetPrgParLoop = (Int, Int)
    executePlugin GetPrgParLoop (line, col) procedure =
        result $ transform GetPrgParLoop () (line, col) procedure
          
getPrgParLoop :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgParLoop (line, col) procedure = up res where
    res = transform GetPrgParLoop () (line, col) procedure        
        
instance Transformable GetPrgParLoop Program where       
    transform t () (line, col) pl@(ParLoop _ _ _ prog inf1 inf2) = Result pl () info where 
        info  = case contains (line, col) inf1  of
                    True -> infoCr where
                        res = transform t () (line, col) prog
                        infoCr = case (fst $ up res) of
                            True -> up res
                            _    -> (True, pl)    
                    _    -> def
    transform t () (line, col) pr = defaultTransform t () (line, col) pr 

-----------------------------------------------------
--- GetPrg plugin for Assign
-----------------------------------------------------

data GetPrgAssign = GetPrgAssign

instance Transformation GetPrgAssign where
    type From GetPrgAssign    = DebugToCSemanticInfo
    type To GetPrgAssign      = DebugToCSemanticInfo
    type Down GetPrgAssign    = (Int, Int)  
    type Up GetPrgAssign      = (Bool, Program DebugToCSemanticInfo)
    type State GetPrgAssign   = ()


instance Plugin GetPrgAssign where
    type ExternalInfo GetPrgAssign = (Int, Int)
    executePlugin GetPrgAssign (line, col) procedure =
        result $ transform GetPrgAssign () (line, col) procedure
          
getPrgAssign :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgAssign (line, col) procedure = up res where
    res = transform GetPrgAssign () (line, col) procedure        
        
instance Transformable GetPrgAssign Program where       
    transform t () (line, col) assign@(Assign _ _ inf1 inf2) = Result assign () info where 
        info  = case contains (line, col) inf1  of
                    True ->  (True, assign)   
                    _    -> def
    transform t () (line, col) pr = defaultTransform t () (line, col) pr         


-----------------------------------------------------
--- GetPrg plugin for Branch
-----------------------------------------------------

data GetPrgBranch = GetPrgBranch

instance Transformation GetPrgBranch where
    type From GetPrgBranch    = DebugToCSemanticInfo
    type To GetPrgBranch     = DebugToCSemanticInfo
    type Down GetPrgBranch   = (Int, Int)  
    type Up GetPrgBranch      = (Bool, Program DebugToCSemanticInfo)
    type State GetPrgBranch   = ()


instance Plugin GetPrgBranch where
    type ExternalInfo GetPrgBranch = (Int, Int)
    executePlugin GetPrgBranch (line, col) procedure =
        result $ transform GetPrgBranch () (line, col) procedure
          
getPrgBranch :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgBranch (line, col) procedure = up res where
    res = transform GetPrgBranch () (line, col) procedure        
        
instance Transformable GetPrgBranch Program where       
    transform t () (line, col) br@(Branch _ prog1 prog2 inf1 inf2) = Result br () info where 
        info  = case contains (line, col) inf1  of
                    True -> infoCr where
                        res1 = transform t () (line, col) prog1
                        res2 = transform t () (line, col) prog2
                        res = combine (up res1) (up res2)
                        infoCr = case (fst res) of
                            True -> res
                            _    -> (True, br)    
                    _    -> def

    transform t () (line, col) pr = defaultTransform t () (line, col) pr         


-----------------------------------------------------
--- GetPrg plugin for Switch
-----------------------------------------------------

data GetPrgSwitch = GetPrgSwitch

instance Transformation GetPrgSwitch where
    type From GetPrgSwitch    = DebugToCSemanticInfo
    type To GetPrgSwitch     = DebugToCSemanticInfo
    type Down GetPrgSwitch  = (Int, Int)  
    type Up GetPrgSwitch      = (Bool, Program DebugToCSemanticInfo)
    type State GetPrgSwitch   = ()


instance Plugin GetPrgSwitch where
    type ExternalInfo GetPrgSwitch = (Int, Int)
    executePlugin GetPrgSwitch (line, col) procedure =
        result $ transform GetPrgSwitch () (line, col) procedure
          
getPrgSwitch :: (Int, Int) -> Module DebugToCSemanticInfo -> (Bool, Program DebugToCSemanticInfo)
getPrgSwitch (line, col) procedure = up res where
    res = transform GetPrgSwitch () (line, col) procedure        
        
instance Transformable GetPrgSwitch Program where       
    transform GetPrgSwitch () (line, col) sw@(Switch _ cases inf1 inf2) = Result sw () info where 
        info  = case contains (line, col) inf1  of
                    True -> infoCr where
                        res = prgSwList (line, col) cases
                        infoCr = case (fst $ res) of
                            True -> res
                            _    -> (True, sw)    
                    _    -> def

    transform t () (line, col) pr = defaultTransform t () (line, col) pr         

prgSwList:: (Int, Int) -> [SwitchCase DebugToCSemanticInfo] -> (Bool, Program DebugToCSemanticInfo)
prgSwList (line, col) [] = def
prgSwList (line, col) (x:xs) = combine info1 info2 where
    info1 = up $ transform GetPrgSwitch () (line, col) x
    info2 = prgSwList (line, col) xs
        
        
-------------------------------------------------
------ Helper functions
-------------------------------------------------      
        
contains (line, col) ((bl, bc), (el, ec)) = (line == bl && bc <= col) || (bl < line && line < el) || (line == el && col <= ec)

myShow :: Program DebugToCSemanticInfo -> String
myShow (Assign lhs rhs inf1 inf2) = "Assign \n" ++ ind show lhs ++ "\n=\n" ++ ind show rhs ++ "\n" ++ show inf1 ++ "\n"  
myShow (Sequence progs inf1 inf2) = "Sequence\n" ++ ind (listprint myShow "\n") progs ++ "\n" ++ show inf1 ++ "\n"
myShow (Branch cond thenBlock elseBlock inf1 inf2) = "Branch\n" ++ ind myShowB thenBlock ++ "\nelse\n" ++ ind myShowB elseBlock ++ "\n" ++ show inf1 ++ "\n"
myShow (ParLoop count bound step block inf1 inf2) 
    = "ParLoop\n count: " ++ show count ++ "\n bound: " ++ show bound ++ "\n step: " ++ show step ++ "\n" ++ ind myShowB block ++ "\n" ++ show inf1 ++ "\n"     
myShow x = show x

myShowB :: Block DebugToCSemanticInfo -> String
myShowB (Block locals prg inf) = "Block\n" ++ ind show locals ++"\n" ++ ind myShow prg ++ show inf