{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Geometry.Ipe.Reader( -- * Reading ipe Files
                                 readRawIpeFile
                               , readIpeFile
                               , readSinglePageFile
                               , ConversionError

                               -- * Reading XML directly
                               , fromIpeXML
                               , readXML

                               -- * Read classes
                               , IpeReadText(..)
                               , IpeRead(..)
                               , IpeReadAttr(..)


                               -- * Some low level implementation functions
                               , ipeReadTextWith
                               , ipeReadObject
                               , ipeReadAttrs
                               , ipeReadRec

                               , Coordinate(..)
                               ) where

import           Control.Applicative((<|>))
import           Control.Lens hiding (Const, rmap)
import qualified Data.ByteString as B
import           Data.Colour.SRGB (RGB(..))
import           Data.Either (rights)
import           Data.Ext
import           Data.Geometry.Box
import           Data.Geometry.Ipe.Attributes
import           Data.Geometry.Ipe.ParserPrimitives (pInteger, pWhiteSpace)
import           Data.Geometry.Ipe.PathParser
import           Data.Geometry.Ipe.Types
import           Data.Geometry.Ipe.Value
import           Data.Geometry.Ipe.Color(IpeColor(..))
import           Data.Geometry.Point
import           Data.Geometry.PolyLine
import qualified Data.Geometry.Polygon as Polygon
import qualified Data.Geometry.Transformation as Trans
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Proxy
import qualified Data.LSeq as LSeq
import           Data.Singletons
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Traversable as Tr
import           Data.Vinyl hiding (Label)
import           Data.Vinyl.Functor
import           Data.Vinyl.TypeLevel
import           Text.XML.Expat.Tree


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

type ConversionError = Text


-- | Given a file path, tries to read an ipe file
readRawIpeFile :: (Coordinate r, Eq r)
               => FilePath -> IO (Either ConversionError (IpeFile r))
readRawIpeFile = fmap fromIpeXML . B.readFile


-- | Given a file path, tries to read an ipe file. This function applies all
-- matrices to objects.
readIpeFile :: (Coordinate r, Eq r)
            => FilePath -> IO (Either ConversionError (IpeFile r))
readIpeFile = fmap (bimap id applyMatrices) . readRawIpeFile


-- | Since most Ipe file contain only one page, we provide a shortcut for that
-- as well. This function applies all matrices.
readSinglePageFile :: (Coordinate r, Eq r)
                   => FilePath -> IO (Either ConversionError (IpePage r))
readSinglePageFile = fmap f . readIpeFile
  where
    f (Left e)  = Left e
    f (Right i) = maybe (Left "No Ipe pages found") Right . firstOf (pages.traverse) $ i

-- | Given a Bytestring, try to parse the bytestring into anything that is
-- IpeReadable, i.e. any of the Ipe elements.
fromIpeXML   :: IpeRead (t r) => B.ByteString -> Either ConversionError (t r)
fromIpeXML b = readXML b >>= ipeRead

-- | Reads the data from a Bytestring into a proper Node
readXML :: B.ByteString -> Either ConversionError (Node Text Text)
readXML = bimap (T.pack . show) id . parse' defaultParseOptions

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

-- | Reading an ipe elemtn from a Text value
class IpeReadText t where
  ipeReadText :: Text -> Either ConversionError t

-- | Reading an ipe lement from Xml
class IpeRead t where
  ipeRead  :: Node Text Text -> Either ConversionError t

--------------------------------------------------------------------------------
--  ReadText instances

instance IpeReadText Text where
  ipeReadText = Right

instance IpeReadText Int where
  ipeReadText = fmap fromInteger . runParser pInteger

instance Coordinate r => IpeReadText (Point 2 r) where
  ipeReadText = readPoint

instance Coordinate r => IpeReadText (Trans.Matrix 3 3 r) where
  ipeReadText = readMatrix

instance IpeReadText LayerName where
  ipeReadText = Right . LayerName

instance IpeReadText PinType where
  ipeReadText "yes" = Right Yes
  ipeReadText "h"   = Right Horizontal
  ipeReadText "v"   = Right Vertical
  ipeReadText ""    = Right No
  ipeReadText _     = Left "invalid PinType"

instance IpeReadText TransformationTypes where
  ipeReadText "affine"       = Right Affine
  ipeReadText "rigid"        = Right Rigid
  ipeReadText "translations" = Right Translations
  ipeReadText _              = Left "invalid TransformationType"

instance IpeReadText FillType where
  ipeReadText "wind"   = Right Wind
  ipeReadText "eofill" = Right EOFill
  ipeReadText _        = Left "invalid FillType"

instance Coordinate r => IpeReadText (IpeArrow r) where
  ipeReadText t = case T.split (== '/') t of
                    [n,s] -> IpeArrow <$> pure n <*> ipeReadText s
                    _     -> Left "ipeArrow: name contains not exactly 1 / "

instance Coordinate r => IpeReadText (IpeDash r) where
  ipeReadText t = Right . DashNamed $ t
                  -- TODO: Implement proper parsing here


ipeReadTextWith     :: (Text -> Either t v) -> Text -> Either ConversionError (IpeValue v)
ipeReadTextWith f t = case f t of
                        Right v -> Right (Valued v)
                        Left _  -> Right (Named t)


instance Coordinate r => IpeReadText (Rectangle () r) where
  ipeReadText = readRectangle

instance Coordinate r => IpeReadText (RGB r) where
  ipeReadText = runParser (pRGB <|> pGrey)
    where
      pGrey = (\c -> RGB c c c) <$> pCoordinate
      pRGB  = RGB <$> pCoordinate <* pWhiteSpace
                  <*> pCoordinate <* pWhiteSpace
                  <*> pCoordinate

instance Coordinate r => IpeReadText (IpeColor r) where
  ipeReadText = fmap IpeColor . ipeReadTextWith ipeReadText

instance Coordinate r => IpeReadText (IpePen r) where
  ipeReadText = fmap IpePen . ipeReadTextWith readCoordinate

instance Coordinate r => IpeReadText (IpeSize r) where
  ipeReadText = fmap IpeSize . ipeReadTextWith readCoordinate


instance Coordinate r => IpeReadText [Operation r] where
  ipeReadText = readPathOperations

instance (Coordinate r, Eq r) => IpeReadText (NE.NonEmpty (PathSegment r)) where
  ipeReadText t = ipeReadText t >>= fromOpsN
    where
      fromOpsN xs = case fromOps xs of
                      Left l       -> Left l
                      Right []     -> Left "No path segments produced"
                      Right (p:ps) -> Right $ p NE.:| ps

      fromOps []            = Right []
      fromOps (MoveTo p:xs) = fromOps' p xs
      fromOps _             = Left "Path should start with a move to"

      fromOps' _ []             = Left "Found only a MoveTo operation"
      fromOps' s (LineTo q:ops) = let (ls,xs) = span' _LineTo ops
                                      pts  = map ext $ s:q:mapMaybe (^?_LineTo) ls
                                      poly = Polygon.fromPoints . dropRepeats $ pts
                                      pl   = fromPoints pts
                                  in case xs of
                                       (ClosePath : xs') -> PolygonPath poly   <<| xs'
                                       _                 -> PolyLineSegment pl <<| xs
      fromOps' _ _ = Left "fromOpts': rest not implemented yet."

      span' pr = L.span (not . isn't pr)

      x <<| xs = (x:) <$> fromOps xs


dropRepeats :: Eq a => [a] -> [a]
dropRepeats = map head . L.group

instance (Coordinate r, Eq r) => IpeReadText (Path r) where
  ipeReadText = fmap (Path . LSeq.fromNonEmpty) . ipeReadText

--------------------------------------------------------------------------------
-- Reading attributes

-- | Basically IpeReadText for attributes. This class is not really meant to be
-- implemented directly. Just define an IpeReadText instance for the type
-- (Apply f at), then the generic instance below takes care of looking up the
-- name of the attribute, and calling the right ipeReadText value. This class
-- is just so that reifyConstraint in `ipeReadRec` can select the right
-- typeclass when building the rec.
class IpeReadAttr t where
  ipeReadAttr  :: Text -> Node Text Text -> Either ConversionError t

instance IpeReadText (Apply f at) => IpeReadAttr (Attr f at) where
  ipeReadAttr n (Element _ ats _) = GAttr <$> Tr.mapM ipeReadText (lookup n ats)
  ipeReadAttr _ _                 = Left "IpeReadAttr: Element expected, Text found"

-- | Combination of zipRecWith and traverse
zipTraverseWith                       :: forall f g h i (rs :: [u]). Applicative h
                                      => (forall (x :: u). f x -> g x -> h (i x))
                                      -> Rec f rs -> Rec g rs -> h (Rec i rs)
zipTraverseWith _ RNil      RNil      = pure RNil
zipTraverseWith f (x :& xs) (y :& ys) = (:&) <$> f x y <*> zipTraverseWith f xs ys

-- | Reading the Attributes into a Rec (Attr f), all based on the types of f
-- (the type family mapping labels to types), and a list of labels (ats).
ipeReadRec       :: forall f ats.
                 ( RecApplicative ats
                 , ReifyConstraint IpeReadAttr (Attr f) ats
                 , RecAll (Attr f) ats IpeReadAttr
                 , AllSatisfy IpeAttrName ats
                 )
                 => Proxy f -> Proxy ats
                 -> Node Text Text
                 -> Either ConversionError (Rec (Attr  f) ats)
ipeReadRec _ _ x = zipTraverseWith f (writeAttrNames r) r'
  where
    r  = rpure (GAttr Nothing)
    r' = reifyConstraint @IpeReadAttr r


    f                              :: forall at.
                                      Const Text at
                                   -> (Dict IpeReadAttr :. Attr f) at
                                   -> Either ConversionError (Attr f at)
    f (Const n) (Compose (Dict _)) = ipeReadAttr n x


-- | Reader for records. Given a proxy of some ipe type i, and a proxy of an
-- coordinate type r, read the IpeAttributes for i from the xml node.
ipeReadAttrs     :: forall proxy proxy' i r f ats.
                 ( f ~ AttrMapSym1 r, ats ~ AttributesOf i
                 , ReifyConstraint IpeReadAttr (Attr f) ats
                 , RecApplicative ats
                 , RecAll (Attr f) ats IpeReadAttr
                 , AllSatisfy IpeAttrName ats
                 )
                 => proxy i -> proxy' r
                 -> Node Text Text
                 -> Either ConversionError (IpeAttributes i r)
ipeReadAttrs _ _ = fmap Attrs . ipeReadRec (Proxy :: Proxy f) (Proxy :: Proxy ats)


-- testSym :: B.ByteString
-- testSym = "<use name=\"mark/disk(sx)\" pos=\"320 736\" size=\"normal\" stroke=\"black\"/>"




-- readAttrsFromXML :: B.ByteString -> Either

-- readSymAttrs :: Either ConversionError (IpeAttributes IpeSymbol Double)
-- readSymAttrs = readXML testSym
--                >>= ipeReadAttrs (Proxy :: Proxy IpeSymbol) (Proxy :: Proxy Double)





-- | If we can ipeRead an ipe element, and we can ipeReadAttrs its attributes
-- we can properly read an ipe object using ipeReadObject
ipeReadObject           :: ( IpeRead (i r)
                           , f ~ AttrMapSym1 r, ats ~ AttributesOf i
                           , RecApplicative ats
                           , ReifyConstraint IpeReadAttr (Attr f) ats
                           , RecAll (Attr f) ats IpeReadAttr
                           , AllSatisfy IpeAttrName ats
                           )
                        => Proxy i -> proxy r -> Node Text Text
                        -> Either ConversionError (i r :+ IpeAttributes i r)
ipeReadObject prI prR xml = (:+) <$> ipeRead xml <*> ipeReadAttrs prI prR xml


--------------------------------------------------------------------------------
-- | Ipe read instances

instance Coordinate r => IpeRead (IpeSymbol r) where
  ipeRead (Element "use" ats _) = case lookup "pos" ats of
      Nothing -> Left "symbol without position"
      Just ps -> flip Symbol name <$> ipeReadText ps
    where
      name = fromMaybe "mark/disk(sx)" $ lookup "name" ats
  ipeRead _ = Left "symbol element expected, text found"

-- | Given a list of Nodes, try to parse all of them as a big text. If we
-- encounter anything else then text, the parsing fails.
allText :: [Node Text Text] -> Either ConversionError Text
allText = fmap T.unlines . mapM unT
  where
    unT (Text t) = Right t
    unT _        = Left "allText: Expected Text, found an Element"

instance (Coordinate r, Eq r) => IpeRead (Path r) where
  ipeRead (Element "path" _ chs) = allText chs >>= ipeReadText
  ipeRead _                      = Left "path: expected element, found text"


lookup'   :: Text -> [(Text,a)] -> Either ConversionError a
lookup' k = maybe (Left $ "lookup' " <> k <> " not found") Right . lookup k

instance Coordinate r => IpeRead (TextLabel r) where
  ipeRead (Element "text" ats chs)
    | lookup "type" ats == Just "label" = Label
                                       <$> allText chs
                                       <*> (lookup' "pos" ats >>= ipeReadText)
    | otherwise                         = Left "Not a Text label"
  ipeRead _                             = Left "textlabel: Expected element, found text"



instance Coordinate r => IpeRead (MiniPage r) where
  ipeRead (Element "text" ats chs)
    | lookup "type" ats == Just "minipage" = MiniPage
                                          <$> allText chs
                                          <*> (lookup' "pos"   ats >>= ipeReadText)
                                          <*> (lookup' "width" ats >>= readCoordinate)
    | otherwise                            = Left "Not a MiniPage"
  ipeRead _                                = Left "MiniPage: Expected element, found text"


instance Coordinate r => IpeRead (Image r) where
  ipeRead (Element "image" ats _) = Image () <$> (lookup' "rect" ats >>= ipeReadText)
  ipeRead _                       = Left "Image: Element expected, text found"

instance (Coordinate r, Eq r) => IpeRead (IpeObject r) where
  ipeRead x = firstRight [ IpeUse       <$> ipeReadObject (Proxy :: Proxy IpeSymbol) r x
                         , IpePath      <$> ipeReadObject (Proxy :: Proxy Path)      r x
                         , IpeGroup     <$> ipeReadObject (Proxy :: Proxy Group)     r x
                         , IpeTextLabel <$> ipeReadObject (Proxy :: Proxy TextLabel) r x
                         , IpeMiniPage  <$> ipeReadObject (Proxy :: Proxy MiniPage)  r x
                         , IpeImage     <$> ipeReadObject (Proxy :: Proxy Image)     r x
                         ]
    where
      r = Proxy :: Proxy r

firstRight :: [Either ConversionError a] -> Either ConversionError a
firstRight = maybe (Left "No matching object") Right . firstOf (traverse._Right)


instance (Coordinate r, Eq r) => IpeRead (Group r) where
  ipeRead (Element "group" _ chs) = Right . Group . rights . map ipeRead $ chs
  ipeRead _                       = Left "ipeRead Group: expected Element, found Text"


instance IpeRead LayerName where
  ipeRead (Element "layer" ats _) = LayerName <$> lookup' "name" ats
  ipeRead _                       = Left "layer: Expected element, found text"

instance IpeRead View where
  ipeRead (Element "view" ats _) = (\lrs a -> View (map LayerName $ T.words lrs) a)
                                <$> lookup' "layers" ats
                                <*> (lookup' "active" ats >>= ipeReadText)
  ipeRead _                      = Left "View Expected element, found text"


-- TODO: this instance throws away all of our error collecting (and is pretty
-- slow/stupid since it tries parsing all children with all parsers)
instance (Coordinate r, Eq r) => IpeRead (IpePage r) where
  ipeRead (Element "page" _ chs) = Right $ IpePage (readAll chs) (readAll chs) (readAll chs)
  ipeRead _                      = Left "page: Element expected, text found"
      -- withDef   :: b -> Either a b -> Either c b
      -- withDef d = either (const $ Right d) Right

      -- readLayers  = withDef ["alpha"] . readAll
      -- readViews   = withDef []        . readAll
      -- readObjects = withDef []        . readAll

-- | try reading everything as an a. Throw away whatever fails.
readAll   :: IpeRead a => [Node Text Text] -> [a]
readAll   = rights . map ipeRead


instance (Coordinate r, Eq r) => IpeRead (IpeFile r) where
  ipeRead (Element "ipe" _ chs) = case readAll chs of
                                    []  -> Left "Ipe: no pages found"
                                    pgs -> Right $ IpeFile Nothing [] (NE.fromList pgs)
  ipeRead _                     = Left "Ipe: Element expected, text found"





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