{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.Ipe.Writer
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
-- Description :  Converting data types into IpeTypes
--
--------------------------------------------------------------------------------
module Data.Geometry.Ipe.Writer where

import           Control.Lens ((^.), (^..), (.~), (&))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import           Data.Colour.SRGB (RGB(..))
import           Data.Ext
import           Data.Fixed
import qualified Data.Foldable as F
import           Data.Geometry.Box
import           Data.Geometry.Ipe.Attributes
import qualified Data.Geometry.Ipe.Attributes as IA
import           Data.Geometry.Ipe.Color (IpeColor(..))
import           Data.Geometry.Ipe.Types
import           Data.Geometry.Ipe.Value
import           Data.Geometry.LineSegment
import           Data.Geometry.Point
import           Data.Geometry.PolyLine
import           Data.Geometry.Polygon (Polygon, outerBoundary, holeList, asSimplePolygon)
import qualified Data.Geometry.Transformation as GT
import           Data.Geometry.Vector
import qualified Data.LSeq as LSeq
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Maybe (catMaybes, mapMaybe, fromMaybe)
import           Data.Ratio
import           Data.Singletons
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text as Text
import           Data.Vinyl hiding (Label)
import           Data.Vinyl.Functor
import           Data.Vinyl.TypeLevel
import           System.IO (hPutStrLn,stderr)
import           Text.XML.Expat.Format (format')
import           Text.XML.Expat.Tree

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

-- | Given a prism to convert something of type g into an ipe file, a file path,
-- and a g. Convert the geometry and write it to file.

-- writeIpe        :: ( RecAll (Page r) gs IpeWrite
--                    , IpeWriteText r
--                    ) => Prism' (IpeFile gs r) g -> FilePath -> g -> IO ()
-- writeIpe p fp g = writeIpeFile (p # g) fp

-- | Write an IpeFiele to file.
writeIpeFile :: IpeWriteText r => FilePath -> IpeFile r -> IO ()
writeIpeFile = flip writeIpeFile'

-- | Creates a single page ipe file with the given page
writeIpePage    :: IpeWriteText r => FilePath -> IpePage r -> IO ()
writeIpePage fp = writeIpeFile fp . singlePageFile


-- | Convert the input to ipeXml, and prints it to standard out in such a way
-- that the copied text can be pasted into ipe as a geometry object.
printAsIpeSelection :: IpeWrite t => t -> IO ()
printAsIpeSelection = C.putStrLn . fromMaybe "" . toIpeSelectionXML

-- | Convert input into an ipe selection.
toIpeSelectionXML :: IpeWrite t => t -> Maybe B.ByteString
toIpeSelectionXML = fmap (format' . ipeSelection) . ipeWrite
  where
    ipeSelection x = Element "ipeselection" [] [x]


-- | Convert to Ipe xml
toIpeXML :: IpeWrite t => t -> Maybe B.ByteString
toIpeXML = fmap format' . ipeWrite


-- | Convert to ipe XML and write the output to a file.
writeIpeFile'      :: IpeWrite t => t -> FilePath -> IO ()
writeIpeFile' i fp = maybe err (B.writeFile fp) . toIpeXML $ i
  where
    err = hPutStrLn stderr $
          "writeIpeFile: error converting to xml. File '" <> fp <> "'not written"

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

-- | For types that can produce a text value
class IpeWriteText t where
  ipeWriteText :: t -> Maybe Text

-- | Types that correspond to an XML Element. All instances should produce an
-- Element. If the type should produce a Node with the Text constructor, use
-- the `IpeWriteText` typeclass instead.
class IpeWrite t where
  ipeWrite :: t -> Maybe (Node Text Text)

instance IpeWrite t => IpeWrite [t] where
  ipeWrite gs = case mapMaybe ipeWrite gs of
                  [] -> Nothing
                  ns -> (Just $ Element "group" [] ns)

instance (IpeWrite l, IpeWrite r) => IpeWrite (Either l r) where
  ipeWrite = either ipeWrite ipeWrite

instance IpeWriteText (Apply f at) => IpeWriteText (Attr f at) where
  ipeWriteText att = _getAttr att >>= ipeWriteText

instance (IpeWriteText l, IpeWriteText r) => IpeWriteText (Either l r) where
  ipeWriteText = either ipeWriteText ipeWriteText


-- | Functon to write all attributes in a Rec
ipeWriteAttrs           :: ( RecordToList rs, RMap rs
                           , ReifyConstraint IpeWriteText (Attr f) rs
                           , AllSatisfy IpeAttrName rs
                           , RecAll (Attr f) rs IpeWriteText
                           ) => IA.Attributes f rs -> [(Text,Text)]
ipeWriteAttrs (Attrs r) = catMaybes . recordToList $ zipRecsWith f (writeAttrNames  r)
                                                                   (writeAttrValues r)
  where
    f (Const n) (Const mv) = Const $ (n,) <$> mv

-- | Writing the attribute values
writeAttrValues :: ( RMap rs, ReifyConstraint IpeWriteText f rs
                   , RecAll f rs IpeWriteText)
                => Rec f rs -> Rec (Const (Maybe Text)) rs
writeAttrValues = rmap (\(Compose (Dict x)) -> Const $ ipeWriteText x)
                . reifyConstraint @IpeWriteText


instance IpeWriteText Text where
  ipeWriteText = Just

-- | Add attributes to a node
addAtts :: Node Text Text -> [(Text,Text)] -> Node Text Text
n `addAtts` ats = n { eAttributes = ats ++ eAttributes n }

-- | Same as `addAtts` but then for a Maybe node
mAddAtts  :: Maybe (Node Text Text) -> [(Text, Text)] -> Maybe (Node Text Text)
mn `mAddAtts` ats = fmap (`addAtts` ats) mn


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

instance IpeWriteText Double where
  ipeWriteText = writeByShow

instance IpeWriteText Int where
  ipeWriteText = writeByShow

instance IpeWriteText Integer where
  ipeWriteText = writeByShow

instance HasResolution p => IpeWriteText (Fixed p) where
  ipeWriteText = writeByShow

-- | This instance converts the ratio to a Pico, and then displays that.
instance Integral a => IpeWriteText (Ratio a) where
  ipeWriteText = ipeWriteText . f . fromRational . toRational
    where
      f :: Pico -> Pico
      f = id

writeByShow :: Show t => t -> Maybe Text
writeByShow = ipeWriteText . T.pack . show

unwords' :: [Maybe Text] -> Maybe Text
unwords' = fmap T.unwords . sequence

unlines' :: [Maybe Text] -> Maybe Text
unlines' = fmap T.unlines . sequence


instance IpeWriteText r => IpeWriteText (Point 2 r) where
  ipeWriteText (Point2 x y) = unwords' [ipeWriteText x, ipeWriteText y]


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

instance IpeWriteText v => IpeWriteText (IpeValue v) where
  ipeWriteText (Named t)  = ipeWriteText t
  ipeWriteText (Valued v) = ipeWriteText v

instance IpeWriteText TransformationTypes where
  ipeWriteText Affine       = Just "affine"
  ipeWriteText Rigid        = Just "rigid"
  ipeWriteText Translations = Just "translations"

instance IpeWriteText PinType where
  ipeWriteText No         = Nothing
  ipeWriteText Yes        = Just "yes"
  ipeWriteText Horizontal = Just "h"
  ipeWriteText Vertical   = Just "v"

instance IpeWriteText r => IpeWriteText (RGB r) where
  ipeWriteText (RGB r g b) = unwords' . map ipeWriteText $ [r,g,b]

deriving instance IpeWriteText r => IpeWriteText (IpeSize  r)
deriving instance IpeWriteText r => IpeWriteText (IpePen   r)
deriving instance IpeWriteText r => IpeWriteText (IpeColor r)

instance IpeWriteText r => IpeWriteText (IpeDash r) where
  ipeWriteText (DashNamed t) = Just t
  ipeWriteText (DashPattern xs x) = (\ts t -> mconcat [ "["
                                                      , Text.intercalate " " ts
                                                      , "] ", t ])
                                    <$> mapM ipeWriteText xs
                                    <*> ipeWriteText x

instance IpeWriteText FillType where
  ipeWriteText Wind   = Just "wind"
  ipeWriteText EOFill = Just "eofill"

instance IpeWriteText r => IpeWriteText (IpeArrow r) where
  ipeWriteText (IpeArrow n s) = (\n' s' -> n' <> "/" <> s') <$> ipeWriteText n
                                                            <*> ipeWriteText s

instance IpeWriteText r => IpeWriteText (Path r) where
  ipeWriteText = fmap concat' . sequence . fmap ipeWriteText . _pathSegments
    where
      concat' = F.foldr1 (\t t' -> t <> "\n" <> t')


--------------------------------------------------------------------------------
instance IpeWriteText r => IpeWrite (IpeSymbol r) where
  ipeWrite (Symbol p n) = f <$> ipeWriteText p
    where
      f ps = Element "use" [ ("pos", ps)
                           , ("name", n)
                           ] []

-- instance IpeWriteText (SymbolAttrElf rs r) => IpeWriteText (SymbolAttribute r rs) where
--   ipeWriteText (SymbolAttribute x) = ipeWriteText x



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

instance IpeWriteText r => IpeWriteText (GT.Matrix 3 3 r) where
  ipeWriteText (GT.Matrix m) = unwords' [a,b,c,d,e,f]
    where
      (Vector3 r1 r2 _) = m

      (Vector3 a c e) = ipeWriteText <$> r1
      (Vector3 b d f) = ipeWriteText <$> r2
      -- TODO: The third row should be (0,0,1) I guess.


instance IpeWriteText r => IpeWriteText (Operation r) where
  ipeWriteText (MoveTo p)         = unwords' [ ipeWriteText p, Just "m"]
  ipeWriteText (LineTo p)         = unwords' [ ipeWriteText p, Just "l"]
  ipeWriteText (CurveTo p q r)    = unwords' [ ipeWriteText p
                                             , ipeWriteText q
                                             , ipeWriteText r, Just "c"]
  ipeWriteText (QCurveTo p q)     = unwords' [ ipeWriteText p
                                             , ipeWriteText q, Just "q"]
  ipeWriteText (Ellipse m)        = unwords' [ ipeWriteText m, Just "e"]
  ipeWriteText (ArcTo m p)        = unwords' [ ipeWriteText m
                                             , ipeWriteText p, Just "a"]
  ipeWriteText (Spline pts)       = unlines' $ map ipeWriteText pts <> [Just "s"]
  ipeWriteText (ClosedSpline pts) = unlines' $ map ipeWriteText pts <> [Just "u"]
  ipeWriteText ClosePath          = Just "h"


instance IpeWriteText r => IpeWriteText (PolyLine 2 () r) where
  ipeWriteText pl = case pl^..points.traverse.core of
    (p : rest) -> unlines' . map ipeWriteText $ MoveTo p : map LineTo rest
    _          -> error "ipeWriteText. absurd. no vertices polyline"
    -- the polyline type guarantees that there is at least one point

instance IpeWriteText r => IpeWriteText (Polygon t () r) where
  ipeWriteText pg = fmap mconcat . traverse f $ asSimplePolygon pg : holeList pg
    where
      f pg' = case pg'^..outerBoundary.traverse.core of
        (p : rest) -> unlines' . map ipeWriteText
                    $ MoveTo p : map LineTo rest ++ [ClosePath]
        _          -> Nothing
    -- TODO: We are not really guaranteed that there is at least one point, it would
    -- be nice if the type could guarantee that.


instance IpeWriteText r => IpeWriteText (PathSegment r) where
  ipeWriteText (PolyLineSegment p) = ipeWriteText p
  ipeWriteText (PolygonPath     p) = ipeWriteText p
  ipeWriteText (EllipseSegment  m) = ipeWriteText $ Ellipse m
  ipeWriteText _                   = error "ipeWriteText: PathSegment, not implemented yet."

instance IpeWriteText r => IpeWrite (Path r) where
  ipeWrite p = (\t -> Element "path" [] [Text t]) <$> ipeWriteText p

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


instance (IpeWriteText r) => IpeWrite (Group r) where
  ipeWrite (Group gs) = ipeWrite gs


instance ( AllSatisfy IpeAttrName rs
         , RecordToList rs, RMap rs
         , ReifyConstraint IpeWriteText (Attr f) rs
         , RecAll (Attr f) rs IpeWriteText
         , IpeWrite g
         ) => IpeWrite (g :+ IA.Attributes f rs) where
  ipeWrite (g :+ ats) = ipeWrite g `mAddAtts` ipeWriteAttrs ats


instance IpeWriteText r => IpeWrite (MiniPage r) where
  ipeWrite (MiniPage t p w) = (\pt wt ->
                              Element "text" [ ("pos", pt)
                                             , ("type", "minipage")
                                             , ("width", wt)
                                             ] [Text t]
                              ) <$> ipeWriteText p
                                <*> ipeWriteText w

instance IpeWriteText r => IpeWrite (Image r) where
  ipeWrite (Image d (Box a b)) = (\dt p q ->
                                   Element "image" [("rect", p <> " " <> q)] [Text dt]
                                 )
                               <$> ipeWriteText d
                               <*> ipeWriteText (a^.core.cwMin)
                               <*> ipeWriteText (b^.core.cwMax)

-- TODO: Replace this one with s.t. that writes the actual image payload
instance IpeWriteText () where
  ipeWriteText () = Nothing

instance IpeWriteText r => IpeWrite (TextLabel r) where
  ipeWrite (Label t p) = (\pt ->
                         Element "text" [("pos", pt)
                                        ,("type", "label")
                                        ] [Text t]
                         ) <$> ipeWriteText p


instance (IpeWriteText r) => IpeWrite (IpeObject r) where
    ipeWrite (IpeGroup     g) = ipeWrite g
    ipeWrite (IpeImage     i) = ipeWrite i
    ipeWrite (IpeTextLabel l) = ipeWrite l
    ipeWrite (IpeMiniPage  m) = ipeWrite m
    ipeWrite (IpeUse       s) = ipeWrite s
    ipeWrite (IpePath      p) = ipeWrite p


ipeWriteRec :: (RecAll f rs IpeWrite, RMap rs, ReifyConstraint IpeWrite f rs, RecordToList rs)
            => Rec f rs -> [Node Text Text]
ipeWriteRec = catMaybes . recordToList
            . rmap (\(Compose (Dict x)) -> Const $ ipeWrite x)
            . reifyConstraint @IpeWrite


-- instance IpeWriteText (GroupAttrElf rs r) => IpeWriteText (GroupAttribute r rs) where
--   ipeWriteText (GroupAttribute x) = ipeWriteText x


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

deriving instance IpeWriteText LayerName

instance IpeWrite LayerName where
  ipeWrite (LayerName n) = Just $ Element "layer" [("name",n)] []

instance IpeWrite View where
  ipeWrite (View lrs act) = Just $ Element "view" [ ("layers", ls)
                                                  , ("active", _layerName act)
                                                  ] []
    where
      ls = T.unwords .  map _layerName $ lrs

instance (IpeWriteText r)  => IpeWrite (IpePage r) where
  ipeWrite (IpePage lrs vs objs) = Just .
                                  Element "page" [] . catMaybes . concat $
                                  [ map ipeWrite lrs
                                  , map ipeWrite vs
                                  , map ipeWrite objs
                                  ]


instance IpeWrite IpeStyle where
  ipeWrite (IpeStyle _ xml) = Just xml


instance IpeWrite IpePreamble where
  ipeWrite (IpePreamble _ latex) = Just $ Element "preamble" [] [Text latex]
  -- TODO: I probably want to do something with the encoding ....

instance (IpeWriteText r) => IpeWrite (IpeFile r) where
  ipeWrite (IpeFile mp ss pgs) = Just $ Element "ipe" ipeAtts chs
    where
      ipeAtts = [("version","70005"),("creator", "HGeometry")]
      chs = mconcat [ catMaybes [mp >>= ipeWrite]
                    , mapMaybe ipeWrite ss
                    , mapMaybe ipeWrite . F.toList $ pgs
                    ]




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

instance (IpeWriteText r, IpeWrite p) => IpeWrite (PolyLine 2 p r) where
  ipeWrite p = ipeWrite path
    where
      path = fromPolyLine $ p & points.traverse.extra .~ ()
      -- TODO: Do something with the p's

fromPolyLine :: PolyLine 2 () r -> Path r
fromPolyLine = Path . LSeq.fromNonEmpty . (:| []) . PolyLineSegment


instance (IpeWriteText r) => IpeWrite (LineSegment 2 p r) where
  ipeWrite (LineSegment' p q) = ipeWrite . fromPolyLine . fromPoints . map (extra .~ ()) $ [p,q]


instance IpeWrite () where
  ipeWrite = const Nothing

-- -- | slightly clever instance that produces a group if there is more than one
-- -- element and just an element if there is only one value produced
-- instance IpeWrite a => IpeWrite [a] where
--   ipeWrite = combine . mapMaybe ipeWrite


combine     :: [Node Text Text] -> Maybe (Node Text Text)
combine []  = Nothing
combine [n] = Just n
combine ns  = Just $ Element "group" [] ns

-- instance (IpeWrite a, IpeWrite b) => IpeWrite (a,b) where
--   ipeWrite (a,b) = combine . catMaybes $ [ipeWrite a, ipeWrite b]



-- -- | The default symbol for a point
-- ipeWritePoint :: IpeWriteText r => Point 2 r -> Maybe (Node Text Text)
-- ipeWritePoint = ipeWrite . flip Symbol "mark/disk(sx)"


-- instance (IpeWriteText r, Floating r) => IpeWrite (Circle r) where
--   ipeWrite = ipeWrite . Path . S2.l1Singleton . fromCircle



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



-- testPoly :: PolyLine 2 () Double
-- testPoly = fromPoints' [origin, Point2 0 10, Point2 10 10, Point2 100 100]




-- testWriteUse :: Maybe (Node Text Text)
-- testWriteUse = ipeWriteExt sym
--   where
--     sym :: IpeSymbol Double :+ (Rec (SymbolAttribute Double) [Size, SymbolStroke])
--     sym = Symbol origin "mark" :+ (  SymbolAttribute (IpeSize  $ Named "normal")
--                                   :& SymbolAttribute (IpeColor $ Named "green")
--                                   :& RNil
--                                   )