{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE OverloadedStrings          #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Miso.OrphanInstances
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Orpthan instances for To/From MisoString instances for several
-- geometric types.
--
--------------------------------------------------------------------------------
module HGeometry.Miso.OrphanInstances
  () where

import           Data.Colour.SRGB (RGB(..))
import           Data.Fixed
import qualified Data.List as List
import           Data.Singletons (Apply)
import           HGeometry.Matrix (Matrix)
import qualified Ipe as Ipe
import qualified Ipe.Attributes as IA
import           Ipe.Color (IpeColor(..))
import           Ipe.Value
import           Miso.String (ToMisoString(..), FromMisoString(..))

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

instance HasResolution p => ToMisoString (Fixed p) where
  toMisoString :: Fixed p -> MisoString
toMisoString = String -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString (String -> MisoString)
-> (Fixed p -> String) -> Fixed p -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Fixed p -> String
forall {k} (a :: k). HasResolution a => Bool -> Fixed a -> String
showFixed Bool
True

instance HasResolution p => FromMisoString (Fixed p) where
  fromMisoStringEither :: MisoString -> Either String (Fixed p)
fromMisoStringEither = (Double -> Fixed p)
-> Either String Double -> Either String (Fixed p)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Fixed p
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Either String Double -> Either String (Fixed p))
-> (MisoString -> Either String Double)
-> MisoString
-> Either String (Fixed p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FromMisoString t => MisoString -> Either String t
fromMisoStringEither @Double

instance ToMisoString Rational where
  toMisoString :: Rational -> MisoString
toMisoString = forall str. ToMisoString str => str -> MisoString
toMisoString @Pico (Pico -> MisoString)
-> (Rational -> Pico) -> Rational -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac

instance FromMisoString Rational where
  fromMisoStringEither :: MisoString -> Either String Rational
fromMisoStringEither = (Pico -> Rational) -> Either String Pico -> Either String Rational
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pico -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Either String Pico -> Either String Rational)
-> (MisoString -> Either String Pico)
-> MisoString
-> Either String Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FromMisoString t => MisoString -> Either String t
fromMisoStringEither @Pico

instance ToMisoString r => ToMisoString (RGB r) where
  toMisoString :: RGB r -> MisoString
toMisoString (RGB r
r r
g r
b) = [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat [ MisoString
"rgb("
                                     , [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat ([MisoString] -> MisoString)
-> ([r] -> [MisoString]) -> [r] -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> [MisoString] -> [MisoString]
forall a. a -> [a] -> [a]
List.intersperse MisoString
" " ([MisoString] -> [MisoString])
-> ([r] -> [MisoString]) -> [r] -> [MisoString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> MisoString) -> [r] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map r -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString ([r] -> MisoString) -> [r] -> MisoString
forall a b. (a -> b) -> a -> b
$ [r
r,r
g,r
b]
                                     , MisoString
")"
                                     ]

--------------------------------------------------------------------------------
-- * Dealing with attributes

instance ToMisoString (Apply f at) => ToMisoString (IA.Attr f at) where
  toMisoString :: Attr f at -> MisoString
toMisoString Attr f at
att = MisoString
-> (Apply f at -> MisoString) -> Maybe (Apply f at) -> MisoString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MisoString
"" Apply f at -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString (Maybe (Apply f at) -> MisoString)
-> Maybe (Apply f at) -> MisoString
forall a b. (a -> b) -> a -> b
$ Attr f at -> Maybe (Apply f at)
forall u (f :: TyFun u (*) -> *) (label :: u).
Attr f label -> Maybe (Apply f label)
IA._getAttr Attr f at
att

instance FromMisoString (Apply f at) => FromMisoString (IA.Attr f at) where
  fromMisoStringEither :: MisoString -> Either String (Attr f at)
fromMisoStringEither = (Apply f at -> Attr f at)
-> Either String (Apply f at) -> Either String (Attr f at)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Apply f at -> Attr f at
forall {u} (f :: u ~> *) (label :: u).
Apply f label -> Attr f label
IA.Attr (Either String (Apply f at) -> Either String (Attr f at))
-> (MisoString -> Either String (Apply f at))
-> MisoString
-> Either String (Attr f at)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> Either String (Apply f at)
forall t. FromMisoString t => MisoString -> Either String t
fromMisoStringEither

instance ToMisoString r => ToMisoString (IpeValue r) where
  toMisoString :: IpeValue r -> MisoString
toMisoString = \case
      Named MisoString
t  -> MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString MisoString
t
      Valued r
v -> r -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString r
v

instance ToMisoString r => ToMisoString (IA.IpePen r) where
  toMisoString :: IpePen r -> MisoString
toMisoString IpePen r
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString r => ToMisoString (IA.IpeSize r) where
  toMisoString :: IpeSize r -> MisoString
toMisoString IpeSize r
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString r => ToMisoString (IA.IpeArrow r) where
  toMisoString :: IpeArrow r -> MisoString
toMisoString IpeArrow r
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString r => ToMisoString (IA.IpeDash r) where
  toMisoString :: IpeDash r -> MisoString
toMisoString IpeDash r
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString r => ToMisoString (Matrix 3 3 r) where
  toMisoString :: Matrix 3 3 r -> MisoString
toMisoString Matrix 3 3 r
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString IA.FillType where
  toMisoString :: FillType -> MisoString
toMisoString FillType
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString IA.PinType where
  toMisoString :: PinType -> MisoString
toMisoString PinType
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString IA.TransformationTypes where
  toMisoString :: TransformationTypes -> MisoString
toMisoString TransformationTypes
_ = MisoString
forall a. Monoid a => a
mempty

instance ToMisoString r => ToMisoString (IpeColor r) where
  toMisoString :: IpeColor r -> MisoString
toMisoString (IpeColor IpeValue (RGB r)
c) = IpeValue (RGB r) -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString IpeValue (RGB r)
c

instance ToMisoString r => ToMisoString (Ipe.Path r) where
  toMisoString :: Path r -> MisoString
toMisoString Path r
_ = MisoString
forall a. Monoid a => a
mempty
    -- FIXME: This does not actually show the path

instance ToMisoString Ipe.LayerName where
  toMisoString :: LayerName -> MisoString
toMisoString (Ipe.LayerName MisoString
t) = MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString MisoString
t

instance FromMisoString Ipe.LayerName where
  fromMisoStringEither :: MisoString -> Either String LayerName
fromMisoStringEither = (MisoString -> LayerName)
-> Either String MisoString -> Either String LayerName
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MisoString -> LayerName
Ipe.LayerName (Either String MisoString -> Either String LayerName)
-> (MisoString -> Either String MisoString)
-> MisoString
-> Either String LayerName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> Either String MisoString
forall t. FromMisoString t => MisoString -> Either String t
fromMisoStringEither


instance ToMisoString r => ToMisoString (IA.TextSizeUnit r) where
  toMisoString :: TextSizeUnit r -> MisoString
toMisoString (IA.TextSizeUnit r
x) = r -> MisoString
forall str. ToMisoString str => str -> MisoString
toMisoString r
x

instance ToMisoString IA.VerticalAlignment where
  toMisoString :: VerticalAlignment -> MisoString
toMisoString = \case
    VerticalAlignment
IA.AlignTop      -> MisoString
"top"
    VerticalAlignment
IA.AlignVCenter  -> MisoString
"center"
    VerticalAlignment
IA.AlignBottom   -> MisoString
"bottom"
    VerticalAlignment
IA.AlignBaseline -> MisoString
"baseline"

instance ToMisoString IA.HorizontalAlignment where
  toMisoString :: HorizontalAlignment -> MisoString
toMisoString = \case
    HorizontalAlignment
IA.AlignLeft    -> MisoString
"left"
    HorizontalAlignment
IA.AlignHCenter -> MisoString
"center"
    HorizontalAlignment
IA.AlignRight   -> MisoString
"right"