hpastetwo

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

import Data.Generics
import Data.Typeable

import Text.Regex.Posix
import Control.Monad.Error
import Data.Char

-- {{{ Utility types/functions
eitherOr :: Either a b -> Either a b -> Either a b
eitherOr x@(Right _) _ = x
eitherOr  _ y  = y



-- {{{ Test it

testProgram :: IO ()
testProgram = do
  putStrLn "##### using syb #####"
  putStrLn "-> test getting project 14 desc"
  print $ getP14Desc test2
  putStrLn "-> test adding a tag"
  print $ addHardTag test2
  putStrLn "##### using multiconAccessor code #####"
  putStrLn "-> test getting project 14 desc"
  print $ getP14Desc2 test2
  putStrLn "-> test adding a tag"
  print $ addHardTag2 test2
  

-- {{{ Using scrap your boilerplate

-- get all headings
getHeadings = everything (++) ([] `mkQ` matchHeading) where
    matchHeading h@(Heading {}) = [h]
    matchHeading _ = []

-- add a row to every table
addToTables = everywhere (mkT addNewRow) where
    addNewRow (Table pos rows) = Table pos (RowSep pos : rows)
    addNewRow x = x


-- find project14, then get description
getP14Desc :: OrgElement -> Either ErrString String
getP14Desc org = everything eitherOr (Left descError `mkQ` findDesc) =<<
                 everything eitherOr (Left findError `mkQ` findP14) org
    where
      findP14 h@(Heading {headingName=name})
          | name == "Project14" = Right h
      findP14 _ = Left findError

      findDesc (Paragraph {paragraphText=text})
          | text =~ "Description" = Right text
      findDesc _ = Left findError

      descError = "Couldn't find description for project"
      findError = "Couldn't find project."
      
addHardTag org = everywhere (mkT addTagToP2) org where
    addTagToP2 h@(Heading {headingName=name}) 
               | name == "Project 2" = everywhere (mkT addTag) h
    addTagToP2 x = x
    addTag text 
           | text =~ "Tags:" = text ++ ",newtag"
    addTag x = x



-- {{{ Using my MulticonAccessor code


projectAccessor name = headingChildren' `chain` -- top level elements
                       headingChildren' `chain` -- level 2 
                       liftFilterS (== name) headingName'



getP14Desc2 = getVal $
              projectAccessor "Project14" `chain`
              headingChildren' `chain`
              liftFilterS (=~ "Description:") paragraphText' `chain`
              paragraphText'

addHardTag2 = modVal
              (projectAccessor "Project 2" `chain`
               headingChildren' `chain`
               liftFilterS (=~ "Tags:") paragraphText' `chain`
               paragraphText')
              (++ ",newtag")
             



-- {{{ Accessor core functions

-- r is the type of the field being accessed, d is the type on the main data type
newtype MultiConAccessor d f = MultiConAccessor ((d -> [f]),((f -> f) -> d -> d))

multiConAccessor :: (d -> [f]) -> ((f -> f) -> d -> d) -> MultiConAccessor d f
multiConAccessor getter setter = MultiConAccessor (getter,setter)


getVal :: MultiConAccessor d f -> d -> [f]
getVal (MultiConAccessor (getF,_)) value = getF value
    



setVal :: MultiConAccessor d f -> f -> d -> d
setVal (MultiConAccessor (_,setF)) v r = setF (const v) r

modVal :: MultiConAccessor d f -> (f -> f) -> d -> d
modVal (MultiConAccessor (getF,setF)) f value = setF f value
                                               
chain :: MultiConAccessor d1 f1 -> MultiConAccessor f1 f2 -> MultiConAccessor d1 f2
(MultiConAccessor (getF1, setF1)) `chain` (MultiConAccessor (getF2, setF2))
    = multiConAccessor getNew setNew where
      getNew value = getF1 value >>= getF2
      setNew f = setF1 (setF2 f)
      -- setNew newValue record = setF1 (setF2 newValue) record





-- | Modifies a MultiConAccessor to only operate for elements that
-- | pass the filter function
liftFilter :: ([f] -> Bool) -> MultiConAccessor d f -> MultiConAccessor d d
liftFilter filterF (MultiConAccessor (getF,modF)) = multiConAccessor getH modH where
    -- getH :: d -> [d]
    getH x = if filterF (getF x) then [x] else []
    modH f d = if filterF (getF d) then f d else d
    -- modH f d = modF (\v -> if filterF v then f v else v) d 

-- | uses f instead of [f] for the type for the filter func
liftFilterS :: (f -> Bool) -> MultiConAccessor d f -> MultiConAccessor d d
liftFilterS f = liftFilter fNew where
    fNew [] = False
    fNew (x:_) = f x
      

           
    
    


-- {{{ Data definitions

data FilePos = FilePos Int
                deriving (Show,Read,Eq,Data,Typeable)

type ErrString = String

class HasPosition a where
    getPos :: a -> FilePos

instance HasPosition OrgElement where
    getPos = elemPosition

instance HasPosition OrgRow where
    getPos = rowPosition

data OrgElement = Heading
    {
      elemPosition :: FilePos,
      headingLevel :: Integer,
      headingName :: String,
      headingChildren :: [OrgElement]
    }
                | Paragraph
    {
      elemPosition :: FilePos,
      paragraphText :: String
    }
                | Table
    {
      elemPosition :: FilePos,
      tableRows :: [OrgRow]
    }
                deriving (Show,Read,Eq,Data,Typeable)


data OrgRow = RowSep  { rowPosition :: FilePos}
            | Row { rowPosition :: FilePos, rows :: [String]}
              deriving (Show,Read,Eq,Data,Typeable)




-- {{{ org accessor definitions (this should be automatically generated)
headingLevel' :: MultiConAccessor OrgElement Integer
headingLevel' = multiConAccessor getH modH where
    getH (Heading {headingLevel=level}) = [level]
    getH _ = []
    modH f h@(Heading {headingLevel=level}) =
        h {headingLevel=f level}
    modH _ x = x


headingName' :: MultiConAccessor OrgElement String
headingName' = multiConAccessor getH modH where
    getH (Heading {headingName=name}) = [name]
    getH _ = []
    modH f h@(Heading {headingName=name}) =
        h {headingName=f name}
    modH _ x = x

headingChildrenRaw' :: MultiConAccessor OrgElement [OrgElement]
headingChildrenRaw' = multiConAccessor getH modH where
    getH (Heading {headingChildren=children}) = [children]
    getH _ = []
    modH f h@(Heading {headingChildren=children}) =
        h {headingChildren=f children}
    modH _ x = x

headingChildren' :: MultiConAccessor OrgElement OrgElement
headingChildren' = multiConAccessor getH modH where
    getH (Heading {headingChildren=children}) = children
    getH _ = []
    modH f h@(Heading {headingChildren=children}) =
        h {headingChildren=fmap f children}
    modH _ x = x



paragraphText' :: MultiConAccessor OrgElement String
paragraphText' = multiConAccessor getH modH where
    getH (Paragraph {paragraphText=text}) = [text]
    getH _ = []
    modH f h@(Paragraph {paragraphText=text}) =
        h {paragraphText=f text}
    modH _ x = x-- wrapMaybe :: (Typeable a, Typeable b) => a -> Maybe b

tableRows' :: MultiConAccessor OrgElement [OrgRow]
tableRows' = multiConAccessor getH modH where
    getH (Table {tableRows=rows}) = [rows]
    getH _ = []
    modH f h@(Table {tableRows=rows}) =
        h {tableRows=f rows}
    modH _ x = x


paragraph' :: MultiConAccessor OrgElement OrgElement
paragraph' = multiConAccessor getH modH where
    getH p@(Paragraph {}) = [p]
    getH _ = []
    modH f p@(Paragraph {}) = f p
    modH _ x = x

heading' :: MultiConAccessor OrgElement OrgElement
heading' = multiConAccessor getH modH where
    getH p@(Heading {}) = [p]
    getH _ = []
    modH f p@(Heading {}) = f p
    modH _ x = x





-- {{{ Test data (test2 refers to the example in the email)


nullP = FilePos 0
-- test = Heading 0 "file.org" [ObjWithPos nullP (Heading 1 "h1" [ObjWithPos nullP (Table [ObjWithPos nullP (Row ["a", "b", "c"]), ObjWithPos nullP RowSep, ObjWithPos nullP (Row ["1", "2", "3"])]), ObjWithPos nullP (Paragraph "hello")]), ObjWithPos nullP (Heading 1 "another heading" [])]
test = Heading nullP 0 "file.org" [  (Heading nullP 1 "h1" [  (Table nullP [  (Row nullP ["a", "b", "c"]),   RowSep nullP,   (Row nullP ["1", "2", "3"])]),   (Paragraph nullP "hello")]),   (Heading nullP 1 "another heading" [])]

test2 = Heading nullP 0 "file.org" [  (Heading nullP 1 "2007 Projects" [  (Heading nullP 2 "Project 1" [  (Paragraph nullP "Description: 1"),   (Paragraph nullP "Tags: None")]),   (Heading nullP 2 "Project 2" [  (Paragraph nullP "Tags: asdf,fdsa"),  (Paragraph nullP "Description: hello")])]),  (Heading nullP 1 "2009 Projects" [  (Heading nullP 2 "Project14" [  (Paragraph nullP "Tags: RightProject"),  (Paragraph nullP "Description: we want this")])])]