cap-1.0: src/Language/Cap/Debug/FDT.hs

module Language.Cap.Debug.FDT
       (buildFDT,fdtParent,fdtQuestion)
       where

import Language.Cap.Interpret.Pretty
import Language.Cap.Debug.Algorithmic
import Language.Cap.Debug.EDT
import Language.Cap.Debug.Trace
import Language.Cap.Debug.TraceMode

import Data.Char
import System.IO.Unsafe

infixl 3 >+<

{- | Generates a question for a node in the ART.  Questions are made up by
     comparing the redex to a most evaluated form.
-}
fdtQuestion :: MapMode -> Graph -> NodeName -> String
fdtQuestion m g n =
  (pretty $ fdtRedex m g n) ++ " =?= " ++ (pretty $ fdtMef m g n) ++ "\n"

-- | Constructs an FDT for a given trace.
buildFDT :: Graph -> ADT
buildFDT g =
  buildFDT' g ""
  where
    -- | Constructs an FDT starting at a specific node in the ART.
    buildFDT' :: Graph -> NodeName -> ADT
    buildFDT' g n = Node n (map (buildFDT' g) (children g n))
    
    -- | Gathers the children of a node in the ART.
    children :: Graph -> NodeName -> [NodeName]
    children g n = [name | name <- allNodes g,    ('r':name) `elem` allNodes g
                                               && fdtParent g name == Just n]

-- | Find the parent (as defined for the FDT) of a node in the ART.
fdtParent :: Graph -> NodeName -> Maybe NodeName
fdtParent g n =
  case nodeValue g n of
    Just (Atom a)          -> edtParent n
    Just (Application f _) -> edtParent (nodeLast g f)

-- | Create a redex for any application or atom node in the trace.
fdtRedex :: MapMode -> Graph -> NodeName -> PrettyTerm
fdtRedex _ g "" = PAtom "main"
fdtRedex m g n  = case nodeValue g n of
                    Just x -> fdtMeaT m g x

fdtMeaT :: MapMode -> Graph -> NodeInfo -> PrettyTerm
fdtMeaT m g (Atom a) = PAtom a
fdtMeaT m g (Application i j) = PApplication (fdtMea m g i) (fdtMef m g j)

fdtMea :: MapMode -> Graph -> NodeName -> PrettyTerm
fdtMea m g n =
  case nodeValue g l of
    Just x -> fdtMeaT m g x
  where
    l = nodeLast g n

-- | Either this is a function symbol (i.e. all lower case letters)
--   or it is an application of a function symbol.
--   Neither may have a result pointer.
--   Longer version is to check the arity of the graph. this is better
--   because it allows for the possibility of a computation not having been
--   demanded.  The short-cut would result in a mapping {} in this situation.
--   Thus if the shortcut is used, empty mappings should be replaced with the _
--   symbol to indicate that the expression was never needed.
isFunction :: Graph -> NodeName -> Bool
isFunction g n = 
  case nodeValue g at of
    Just (Atom a)          -> isFunctionName g at
    Just (Application i j) -> isFunctionName g i
  where
    at = (nodeLast g n)

isFunctionName :: Graph -> NodeName -> Bool
isFunctionName g n =
  case nodeValue g n of
    Just (Atom a)          -> isAllLowerCase a
    Just (Application i j) -> isFunctionName g i
  where
    isAllLowerCase :: String -> Bool
    isAllLowerCase = all (`elem` "abcdefghijklmnopqrstuvwxyz")

-- | Find the most evaluated form for any node in the trace
fdtMef :: MapMode -> Graph -> NodeName -> PrettyTerm
fdtMef m g n =
  if isFunction g n
    then fdtMap m g (nodeLast g n)
    else fdtMea m g n

(>+<) :: NodeName -> Graph -> NodeName -> Bool
(n >+< g) m = n /= m && ('r':m) `elem` allNodes g && n `elem` nodeHeads g m

(>-<) :: NodeName -> Graph -> NodeName -> Bool
(n >-< g) m = n /= m && ('r':m) `elem` allNodes g && nodeHead g m == n

fdtMap :: MapMode -> Graph -> NodeName -> PrettyTerm
fdtMap Index g n =
  PMap [M (args Index g m n) (fdtMef Index g m) | m <- allNodes g, (n >+< g) m]
fdtMap IndexFunctions g n =
  fdtMap' g n (nodeHead g n)
fdtMap OnTheFly g n =
  PMap (map (makeMap g) (filter (isAppOf g n) (allApplications g)))
  -- Needs to be an underscore if it's an empty mapping, because we don't know
  -- if it's a function symbol or a value

fdtMap' :: Graph -> NodeName -> NodeName -> PrettyTerm
fdtMap' g n m =
  PMap [M (args IndexFunctions g m' n) (fdtMef IndexFunctions g m')
          | m' <- allNodes g, (m >-< g) m' && n `elem` nodeHeads g m']

args :: MapMode -> Graph -> NodeName -> NodeName -> [PrettyTerm]
args mm g m n =
  if m /= n then
    case nodeValue g m of
      Just (Application i j) -> args mm g (nodeLast g i) n ++ [fdtMef mm g j]
      Just (Atom x)          -> []
  else []

isAppOf :: Graph -> NodeName -> NodeName -> Bool
isAppOf g n m = 
  case nodeValue g m of
    Just (Application n' o) -> n == nodeLast g n'
    _                       -> False

makeMap :: Graph -> NodeName -> Mapping
makeMap g m =
  case nodeValue g m of
    Just (Application _ o) -> M [fdtMef OnTheFly g o] (fdtRes OnTheFly g m)

fdtRes :: MapMode -> Graph -> NodeName -> PrettyTerm
fdtRes m g n = if ('r':n) `elem` allNodes g then fdtMef m g n
                                            else fdtMap m g n