StrategyInfo.hs

-----------------------------------------------------------------------------
-- Copyright 2018, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Converting a strategy to XML, and the other way around.
--
-----------------------------------------------------------------------------

module Ideas.Encoding.StrategyInfo (strategyToXML) where

import Ideas.Common.Id
import Ideas.Common.Strategy.Abstract
import Ideas.Common.Strategy.Configuration
import Ideas.Common.Strategy.CyclicTree
import Ideas.Common.Strategy.StrategyTree (StrategyTree)
import Ideas.Text.XML

-----------------------------------------------------------------------
-- Strategy to XML

strategyToXML :: IsStrategy f => f a -> XML
strategyToXML = strategyTreeToXML . toStrategyTree

nameAttr :: Id -> XMLBuilder
nameAttr info = "name" .=. showId info

strategyTreeToXML :: StrategyTree a -> XML
strategyTreeToXML tree = makeXML "label" $
   case isLabel tree of
      Just (l, a) -> nameAttr l <> strategyTreeBuilder a
      _ -> strategyTreeBuilder tree

strategyTreeBuilder :: StrategyTree a -> XMLBuilder
strategyTreeBuilder = fold emptyAlg
   { fNode = \def xs ->
        case xs of
           [x] | isConfigId def
             -> addProperty (show def) x
           _ -> tag (show def) (mconcat xs)
   , fLeaf = \r ->
        tag "rule" ("name" .=. show r)
   , fLabel = \l a ->
        tag "label" (nameAttr l <> a)
   , fRec = \n a ->
        tag "rec" (("var" .=. show n) <> a)
   , fVar = \n ->
        tag "var" ("var" .=. show n)
   }

addProperty :: String -> XMLBuilder -> XMLBuilder
addProperty s a =
   case fromBuilder a of
      Just e | name e `elem` ["label", "rule"] ->
         builder e { attributes = attributes e ++ [s := "true"] }
      _      -> tag s a

-----------------------------------------------------------------------
-- XML to strategy

{-
xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) ->  XML -> m (Strategy a)
xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g
 where
   g info = case f (showId info) of
               Just r  -> return r
               Nothing -> fail $ "Unknown rule: " ++ showId info

xmlToInfo :: Monad m => XML -> m Id
xmlToInfo xml = do
   n <- findAttribute "name" xml
   -- let boolAttr s = fromMaybe False (findBool s xml)
   return (newId n)

findBool :: Monad m => String -> XML -> m Bool
findBool attr xml = do
   s <- findAttribute attr xml
   case map toLower s of
      "true"  -> return True
      "false" -> return False
      _       -> fail "not a boolean"

readStrategy :: Monad m => (XML -> m Id) -> (Id -> m (Rule a)) -> XML -> m (Core a)
readStrategy toLabel findRule xml = error "not implemented" do
   xs <- mapM (readStrategy toLabel findRule) (children xml)
   let s = name xml
   case lookup s table of
      Just f  -> f s xs
      Nothing ->
         fail $ "Unknown strategy combinator " ++ show s
 where
   buildSequence _ xs
      | null xs   = return Succeed
      | otherwise = return (foldr1 (:*:) xs)
   buildChoice _ xs
      | null xs   = return Fail
      | otherwise = return (foldr1 (:|:) xs)
   buildOrElse _ xs
      | null xs   = return Fail
      | otherwise = return (foldr1 (:|>:) xs)
   buildInterleave _ xs
      | null xs   = return succeedCore
      | otherwise = return (foldr1 (:%:) xs)
   buildLabel x = do
      info <- toLabel xml
      return (Label info x)
   buildRule = do
      info <- toLabel xml
      r    <- findRule info
      return (Label info (Sym r))
   buildVar = do
      s <- findAttribute "var" xml
      i <- maybe (fail "var: not an int") return (readInt s)
      return (Var i)

   comb0 a _ [] = return a
   comb0 _ s _  = fail $ "Strategy combinator " ++ s ++ "expects 0 args"

   comb1 f _ [x] = return (f x)
   comb1 _ s _   = fail $ "Strategy combinator " ++ s ++ "expects 1 arg"

   join2 f g a b = join (f g a b)

   table =
      [ ("sequence",   buildSequence)
      , ("choice",     buildChoice)
      , ("orelse",     buildOrElse)
      , ("interleave", buildInterleave)
      , ("label",      join2 comb1 buildLabel)
     -- , ("atomic",     comb1 Atomic)
      , ("rule",       join2 comb0 buildRule)
      , ("var",        join2 comb0 buildVar)
--      , ("succeed",    comb0 Succeed)
      --, ("fail",       comb0 Fail)
      ]

-}