content: {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE InstanceSigs #-}
  {-# LANGUAGE OverloadedLists #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  module Typst.Types
    ( RE,
      Val (..),
      ValType (..),
      valType,
      hasType,
      FromVal (..),
      Negatable (..),
      Summable (..),
      Multipliable (..),
      Selector (..),
      Symbol (..),
      Content (..),
      Function (..),
      Arguments (..),
      getPositionalArg,
      getNamedArg,
      Compare (..),
      MP,
      Scope (..),
      FlowDirective (..),
      Operations (..),
      XdgDirectory (..),
      EvalState (..),
      emptyEvalState,
      ShowRule (..),
      Counter (..),
      LUnit (..),
      Length (..),
      renderLength,
      Horiz (..),
      Vert (..),
      Color (..),
      Direction (..),
      Identifier (..), -- reexported
      lookupIdentifier,
      joinVals,
      prettyVal,
      valToContent,
      prettyType,
      repr,
      Attempt (..),
    )
  where
  
  import Control.Monad (MonadPlus (..))
  import Data.Aeson (FromJSON, parseJSON)
  import qualified Data.Aeson as Aeson
  import qualified Data.ByteString as BS
  import Data.Data (Typeable)
  import qualified Data.Foldable as F
  import Data.Functor.Classes (Ord1 (liftCompare))
  import qualified Data.Map as M
  import qualified Data.Map.Ordered as OM
  import Data.Maybe (fromMaybe, isJust, catMaybes)
  import Data.Scientific (floatingOrInteger)
  import Data.Sequence (Seq)
  import qualified Data.Sequence as Seq
  import qualified Data.Set as Set
  import Data.String
  import Data.Text (Text)
  import qualified Data.Text as T
  import Data.ByteString (ByteString)
  import Data.Vector (Vector)
  import qualified Data.Vector as V
  import Text.Parsec
  import qualified Toml
  import qualified Toml.Schema as Toml
  import qualified Toml.Pretty as Toml
  import qualified Text.PrettyPrint as P
  import Text.Read (readMaybe)
  import Typst.Regex (RE, makeLiteralRE)
  import Typst.Syntax (Identifier (..), Markup)
  import Data.Time (UTCTime, Day, DiffTime, timeOfDayToTime, localDay, localTimeOfDay)
  import Data.Time.Format (defaultTimeLocale, formatTime)
  import System.Directory (XdgDirectory(..))
  
  -- | A Typst value. More documentation can be found in the 
  -- [Foundations chapter](https://typst.app/docs/reference/foundations/)
  -- of the Typst reference manual. A more concise (but somewhat outdated) 
  -- summary can also be found in 
  -- [L. Mädje "Typst: a programmable markup language for typesetting", page 32-33](https://www.user.tu-berlin.de/laurmaedje/programmable-markup-language-for-typesetting.pdf).
  data Val
    -- | The @none@ value, indicates the absence of any other value.
    = VNone
    -- | The @auto@ value, used to automatically set an appropriate value.
    | VAuto
    -- | A @bool@ value.
    | VBoolean !Bool
    -- | An @int@ value.
    | VInteger !Integer
    -- | A @float@ value.
    | VFloat !Double
    -- | A @ratio@ value, a proportion of a certain whole, for example @50%@.
    | VRatio !Rational
    -- | A @length@ or a @relative@ value.
    | VLength !Length
    -- | An @alignment@ value, indicating the alignment of some content along both
    -- the horizontal and vertical axes.
    | VAlignment (Maybe Horiz) (Maybe Vert)
    -- | An @angle@ value (expressed internally in degrees).
    | VAngle !Double
    -- | A @fraction@ value, defining the proportions of remaing space is 
    -- to be distributed, e.g. @2 fr@.
    | VFraction !Double
    -- | A @color@ value. Not all Typst color spaces are supported; 
    -- only @rgb@, @cmyk@, and @luma@ are available. 
    -- See issue [#35](https://github.com/jgm/typst-hs/issues/35#issuecomment-1926182040).
    | VColor !Color
    -- | A @symbol@ value, representing a Unicode symbol.
    | VSymbol !Symbol
    -- | A UTF-8 encoded text @string@.
    | VString !Text
    -- | A @regex@ (regular expression). See 'RE' for details.
    | VRegex !RE
    -- | A @datetime@ value, a date, a time, or a combination of both.
    | VDateTime (Maybe Day) (Maybe DiffTime)
    -- | A @content@ value, see 'Content' for more details.
    | VContent (Seq Content)
    -- | An @array@ value, for example @(10, 20, 30)@.
    | VArray (Vector Val)
    -- | A @dictionary@ value, for example @(a:20, b:30)@.
    | VDict (OM.OMap Identifier Val)
    | VTermItem (Seq Content) (Seq Content)
    -- | A @direction@ to lay out content.
    | VDirection Direction
    -- | A Typst function.
    | VFunction (Maybe Identifier) (M.Map Identifier Val) Function
    | -- first param is Just ident if element function
      -- second param is a map of subfunctions in this function's scope
      -- | Positional and named function arguments
      VArguments Arguments
    -- | A @label@ to some element, for example @<hello>@. 
    | VLabel !Text
    | VCounter !Counter
    | VSelector !Selector
    | VModule Identifier (M.Map Identifier Val)
    | VStyles -- just a placeholder for now
    | VVersion [Integer]
    | VBytes ByteString
    | VType !ValType
    deriving (Show, Eq, Typeable)
  
  instance FromJSON Val where
    parseJSON v@(Aeson.Object {}) =
      VDict . OM.fromList . M.toList . M.mapKeys Identifier <$> parseJSON v
    parseJSON v@(Aeson.Array {}) = VArray <$> parseJSON v
    parseJSON (Aeson.String t) = pure $ VString t
    parseJSON (Aeson.Number n) =
      pure $ either VFloat VInteger (floatingOrInteger n)
    parseJSON (Aeson.Bool b) = pure $ VBoolean b
    parseJSON Aeson.Null = pure VNone
  
  instance Toml.FromValue Val where
    fromValue = pure . tomlToVal
  
  tomlToVal :: Toml.Value' a -> Val
  tomlToVal (Toml.Bool' _ x) = VBoolean x
  tomlToVal (Toml.Integer' _ x) = VInteger x
  tomlToVal (Toml.Text' _ x) = VString x
  tomlToVal (Toml.Double' _ x) = VFloat x
  tomlToVal (Toml.TimeOfDay' _ x) = VDateTime Nothing (Just (timeOfDayToTime x))
  tomlToVal (Toml.Day' _ x) = VDateTime (Just x) Nothing
  tomlToVal (Toml.LocalTime' _ x) = VDateTime (Just (localDay x)) (Just (timeOfDayToTime (localTimeOfDay x)))
  tomlToVal (Toml.List' _ x) = VArray (V.fromList (map tomlToVal x))
  tomlToVal (Toml.Table' _ (Toml.MkTable x)) = VDict (OM.fromList [(Identifier k, tomlToVal v) | (k,(_,v)) <- M.assocs x])
    -- typst specifies that unsupported datetimes map to strings and we don't have a place for the timezone
  tomlToVal v@Toml.ZonedTime'{} = VString (T.pack (show (Toml.prettyValue v)))
  
  -- | A Typst type, see documentation for 'Val'.
  data ValType
    = TNone
    | TAuto
    | TBoolean
    | TInteger
    | TFloat
    | TRatio
    | TLength
    | TAlignment
    | TAngle
    | TFraction
    | TColor
    | TSymbol
    | TString
    | TRegex
    | TDateTime
    | TContent
    | TArray
    | TDict
    | TTermItem
    | TDirection
    | TFunction
    | TArguments
    | TModule
    | TSelector
    | TStyles
    | TLabel
    | TCounter
    | TLocation
    | TVersion
    | TBytes
    | TType
    | TAny
    | ValType :|: ValType
    deriving (Show, Eq, Ord, Typeable)
  
  valType :: Val -> ValType
  valType v =
    case v of
      VNone {} -> TNone
      VAuto {} -> TAuto
      VBoolean {} -> TBoolean
      VInteger {} -> TInteger
      VFloat {} -> TFloat
      VRatio {} -> TRatio
      VLength {} -> TLength
      VAlignment {} -> TAlignment
      VAngle {} -> TAngle
      VFraction {} -> TFraction
      VColor {} -> TColor
      VSymbol {} -> TSymbol
      VString {} -> TString
      VRegex {} -> TRegex
      VDateTime {} -> TDateTime
      VContent {} -> TContent
      VArray {} -> TArray
      VDict {} -> TDict
      VTermItem {} -> TTermItem
      VDirection {} -> TDirection
      VLabel {} -> TLabel
      VCounter {} -> TCounter
      VFunction {} -> TFunction
      VArguments {} -> TArguments
      VModule {} -> TModule
      VSelector {} -> TSelector
      VStyles {} -> TStyles
      VVersion {} -> TVersion
      VBytes {} -> TBytes
      VType {} -> TType
  
  hasType :: ValType -> Val -> Bool
  hasType TAny _ = True
  hasType TLocation (VDict m) =
    isJust (OM.lookup "page" m >> OM.lookup "x" m >> OM.lookup "y" m)
  hasType (t1 :|: t2) v = hasType t1 v || hasType t2 v
  hasType t v = t == valType v
  
  class FromVal a where
    fromVal :: (MonadPlus m, MonadFail m) => Val -> m a
  
  instance FromVal Val where
    fromVal = pure
  
  instance FromVal (Seq Content) where
    fromVal = pure . valToContent
  
  instance FromVal Text where
    fromVal (VContent cs) = mconcat <$> mapM go (F.toList cs)
      where
        go (Txt t) = pure t
        go (Elt "text" _ fs) =
          maybe
            (fail "text element has no body")
            fromVal
            (M.lookup "body" fs)
        go _ = fail "not a text element"
    fromVal (VString t) = pure t
    fromVal _ = fail "not a string or content value"
  
  instance FromVal String where
    fromVal = fmap T.unpack . fromVal
  
  instance FromVal RE where
    fromVal (VString t) = makeLiteralRE t
    fromVal (VRegex re) = pure re
    fromVal _ = fail "not a string or regex"
  
  instance FromVal Integer where
    fromVal val =
      case val of
        VInteger x -> pure $ fromIntegral x
        VFloat x -> pure $ floor x
        VRatio x -> pure $ floor x
        VBoolean x -> pure $ if x then 1 else 0
        VString x | Just (xint :: Integer) <- readMaybe (T.unpack x) -> pure xint
        _ -> fail $ "Cannot convert " <> show val <> " to integer"
  
  instance FromVal Int where
    fromVal val = (fromIntegral :: Integer -> Int) <$> fromVal val
  
  instance FromVal Rational where
    fromVal val =
      case val of
        VRatio x -> pure x
        VInteger x -> pure $ fromIntegral x
        VString x | Just (xrat :: Rational) <- readMaybe (T.unpack x) -> pure xrat
        _ -> fail $ "Cannot convert " <> show val <> " to rational"
  
  instance FromVal Double where
    fromVal val =
      case val of
        VInteger x -> pure $ fromIntegral x
        VFloat x -> pure x
        VRatio x -> pure $ fromRational x
        VString x | Just (xdb :: Double) <- readMaybe (T.unpack x) -> pure xdb
        _ -> fail $ "Cannot convert " <> show val <> " to double"
  
  instance FromVal Bool where
    fromVal (VBoolean b) = pure b
    fromVal val = fail $ "Cannot convert " <> show val <> " to boolean"
  
  instance FromVal Length where
    fromVal (VLength x) = pure x
    fromVal (VRatio x) = pure $ LRatio x
    fromVal val = fail $ "Cannot convert " <> show val <> " to length"
  
  instance FromVal Function where
    fromVal (VFunction _ _ f) = pure f
    fromVal val = fail $ show val <> " is not a function"
  
  instance FromVal Direction where
    fromVal (VDirection d) = pure d
    fromVal val = fail $ show val <> " is not a direction"
  
  instance FromVal Counter where
    fromVal (VString t) = pure $ CounterCustom t
    fromVal (VLabel t) = pure $ CounterLabel t
    fromVal (VFunction (Just "page") _ _) = pure $ CounterPage
    fromVal (VFunction (Just name) _ _) = pure $ CounterSelector $ SelectElement name []
    fromVal (VSelector s) = pure $ CounterSelector s
    fromVal val = fail $ show val <> " is not a counter"
  
  instance FromVal Selector where
    fromVal (VSelector s) = pure s
    fromVal val = fail $ show val <> " is not a selector"
  
  instance FromVal a => FromVal (Maybe a) where
    fromVal VNone = pure Nothing
    fromVal x = (Just <$> fromVal x) `mplus` pure Nothing
  
  instance FromVal a => FromVal (Vector a) where
    fromVal (VArray v) = V.mapM fromVal v
    fromVal val = fail $ "Could not convert " <> show val <> " to array"
  
  data Selector
    = SelectElement Identifier [(Identifier, Val)]
    | SelectString !Text
    | SelectRegex !RE
    | SelectLabel !Text
    | SelectOr Selector Selector
    | SelectAnd Selector Selector
    | SelectBefore Selector Selector
    | SelectAfter Selector Selector
    deriving (Show, Eq, Ord, Typeable)
  
  data Symbol = Symbol
    { symDefault :: !Text,
      symAccent :: !Bool,
      symVariants :: [(Set.Set Text, Text)]
    }
    deriving (Show, Eq, Typeable)
  
  joinVals :: MonadFail m => Val -> Val -> m Val
  joinVals = go
    where
      go VNone v = pure v
      go v VNone = pure v
      go v (VSymbol (Symbol s _ _)) = go v (VString s)
      go (VString t) (VString t') = pure $ VString (t <> t')
      go (VString t) (VContent cs) = pure $ VContent (Txt t Seq.<| cs)
      go (VContent cs) (VString t) = pure $ VContent (cs Seq.|> Txt t)
      go (VContent cs) (VContent cs') = pure $ VContent (cs <> cs')
      go (VArray vec) (VArray vec') = pure $ VArray (vec <> vec')
      go x y = pure $ VContent $ valToContent x <> valToContent y
  
  class Compare a where
    comp :: a -> a -> Maybe Ordering
  
  instance Compare Val where
    comp VNone VNone = Just EQ
    comp VAuto VAuto = Just EQ
    comp (VBoolean b1) (VBoolean b2) = Just $ compare b1 b2
    comp (VInteger i1) (VInteger i2) = Just $ compare i1 i2
    comp (VFloat f1) (VFloat f2) = Just $ compare f1 f2
    comp (VInteger i1) (VFloat f2) = Just $ compare (fromIntegral i1) f2
    comp (VFloat f1) (VInteger i2) = Just $ compare f1 (fromIntegral i2)
    comp (VRatio r1) (VRatio r2) = Just $ compare r1 r2
    comp (VRatio r1) (VLength (LRatio r2)) = Just $ compare r1 r2
    comp (VLength (LRatio r1)) (VRatio r2) = Just $ compare r1 r2
    comp (VRatio r1) x = comp (VFloat (fromRational r1)) x
    comp x (VRatio r1) = comp x (VFloat (fromRational r1))
    comp (VLength x1) (VLength x2) = compareLength x1 x2
    comp (VAlignment {}) (VAlignment {}) = Nothing
    comp (VAngle x1) (VAngle x2) = Just $ compare x1 x2
    comp (VFraction x1) (VFraction x2) = Just $ compare x1 x2
    comp (VColor c1) (VColor c2) = Just $ compare c1 c2
    comp (VSymbol (Symbol s1 _ _)) (VSymbol (Symbol s2 _ _)) = Just $ compare s1 s2
    comp (VString s1) (VString s2) = Just $ compare s1 s2
    comp (VContent c1) (VContent c2) = Just $ compare c1 c2
    comp (VArray v1) (VArray v2) =
      Just $ liftCompare (\x y -> fromMaybe LT (comp x y)) v1 v2
    comp (VDict m1) (VDict m2) =
      Just $ liftCompare (\x y -> fromMaybe LT (comp x y)) (OM.toMap m1) (OM.toMap m2)
    comp (VFunction (Just i1) _ _) (VFunction (Just i2) _ _) = Just $ compare i1 i2
    comp (VType ty1) (VType ty2) = Just $ compare ty1 ty2
    comp (VType TInteger) (VString "integer") = Just EQ
    comp (VString "integer") (VType TInteger) = Just EQ
    comp (VType ty) (VString s) = Just $ compare (prettyType ty) s
    comp (VString s) (VType ty)  = Just $ compare s (prettyType ty)
    comp (VVersion as) (VVersion bs)
      | length as > length bs =
         Just $ compare as (bs ++ replicate (length as - length bs) 0)
      | otherwise =
         Just $ compare (as ++ replicate (length as - length bs) 0) bs
    comp _ _ = Nothing
  
  instance Ord Val where
    compare v1 v2 = fromMaybe EQ $ comp v1 v2
  
  class Negatable a where
    maybeNegate :: a -> Maybe a
  
  instance Negatable Val where
    maybeNegate (VInteger i) = pure $ VInteger (-i)
    maybeNegate (VFloat f) = pure $ VFloat (-f)
    maybeNegate (VLength x) = pure $ VLength $ negateLength x
    maybeNegate (VAngle x) = pure $ VAngle (-x)
    maybeNegate (VFraction x) = pure $ VFraction (-x)
    maybeNegate (VRatio x) = pure $ VRatio (-x)
    maybeNegate v = fail $ "could not negate " <> show v
  
  class Negatable a => Summable a where
    maybePlus :: a -> a -> Maybe a
    maybeMinus :: a -> a -> Maybe a
    maybeMinus x y = maybeNegate y >>= maybePlus x
  
  instance Summable Val where
    maybePlus VNone x = pure x
    maybePlus x VNone = pure x
    maybePlus (VInteger i1) (VInteger i2) = pure $ VInteger (i1 + i2)
    maybePlus (VRatio r1) (VRatio r2) = pure $ VRatio (r1 + r2)
    maybePlus (VFloat f1) (VFloat f2) = pure $ VFloat (f1 + f2)
    maybePlus (VInteger i1) (VFloat f2) = pure $ VFloat (fromIntegral i1 + f2)
    maybePlus (VFloat f1) (VInteger i2) = pure $ VFloat (f1 + fromIntegral i2)
    maybePlus (VInteger i1) (VRatio r2) = pure $ VRatio (fromIntegral i1 + r2)
    maybePlus (VRatio r1) (VInteger i2) = pure $ VRatio (r1 + fromIntegral i2)
    maybePlus (VFloat f1) (VRatio r2) = pure $ VFloat (f1 + fromRational r2)
    maybePlus (VRatio r1) (VFloat f2) = pure $ VFloat (fromRational r1 + f2)
    maybePlus (VString s1) (VString s2) = pure $ VString (s1 <> s2)
    maybePlus (VContent c1) (VContent c2) = pure $ VContent (c1 <> c2)
    maybePlus (VString s1) (VContent c2) = pure $ VContent (Txt s1 Seq.<| c2)
    maybePlus (VContent c1) (VString s2) = pure $ VContent (c1 Seq.|> Txt s2)
    maybePlus (VString s1) sym@(VSymbol{}) = pure $ VString (s1 <> repr sym)
    maybePlus sym@(VSymbol{}) (VString s2) = pure $ VString (repr sym <> s2)
    maybePlus (VLength l1) (VLength l2) = pure $ VLength (l1 <> l2)
    maybePlus (VLength l1) (VRatio r1) = pure $ VLength (l1 <> LRatio r1)
    maybePlus (VRatio r1) (VLength l1) = pure $ VLength (l1 <> LRatio r1)
    maybePlus (VAngle a1) (VAngle a2) = pure $ VAngle (a1 + a2)
    maybePlus (VFraction f1) (VFraction f2) = pure $ VFraction (f1 + f2)
    maybePlus (VArray v1) (VArray v2) = pure $ VArray (v1 <> v2)
    maybePlus (VDict m1) (VDict m2) = pure $ VDict (m1 OM.<>| m2)
    maybePlus (VColor c) (VLength l) =
      -- Stroke '1pt + red'
      pure $ VDict $ OM.fromList [("thickness", VLength l), ("color", VColor c)]
    maybePlus (VLength l) (VColor c) = maybePlus (VColor c) (VLength l)
    maybePlus v1 v2 = fail $ "could not add " <> show v1 <> " and " <> show v2
  
  class Multipliable a where
    maybeTimes :: a -> a -> Maybe a
    maybeDividedBy :: a -> a -> Maybe a
  
  instance Multipliable Val where
    maybeTimes (VInteger i1) (VInteger i2) = pure $ VInteger (i1 * i2)
    maybeTimes (VFloat x1) (VFloat x2) = pure $ VFloat (x1 * x2)
    maybeTimes (VInteger i1) (VFloat f2) = pure $ VFloat (fromIntegral i1 * f2)
    maybeTimes (VFloat f1) (VInteger i2) = pure $ VFloat (f1 * fromIntegral i2)
    maybeTimes (VInteger i) (VArray v) =
      pure $ VArray (mconcat $ replicate (fromIntegral i) v)
    maybeTimes (VArray v) (VInteger i) =
      pure $ VArray (mconcat $ replicate (fromIntegral i) v)
    maybeTimes (VInteger i) (VString s)
      | i >= 0 = pure $ VString (T.replicate (fromIntegral i) s)
    maybeTimes (VString s) (VInteger i)
      | i >= 0 = pure $ VString (T.replicate (fromIntegral i) s)
    maybeTimes (VInteger i) (VContent c)
      | i >= 0 = pure $ VContent (mconcat $ replicate (fromIntegral i) c)
    maybeTimes (VContent c) (VInteger i)
      | i >= 0 = pure $ VContent (mconcat $ replicate (fromIntegral i) c)
    maybeTimes (VInteger i) (VLength l) = pure $ VLength $ timesLength (fromIntegral i) l
    maybeTimes (VLength l) (VInteger i) = pure $ VLength $ timesLength (fromIntegral i) l
    maybeTimes (VRatio r) (VLength l) = pure $ VLength $ timesLength (fromRational r) l
    maybeTimes (VLength l) (VRatio r) = pure $ VLength $ timesLength (fromRational r) l
    maybeTimes (VFloat f) (VLength l) = pure $ VLength $ timesLength f l
    maybeTimes (VLength l) (VFloat f) = pure $ VLength $ timesLength f l
    maybeTimes (VInteger i) (VAngle a) = pure $ VAngle (fromIntegral i * a)
    maybeTimes (VAngle a) (VInteger i) = pure $ VAngle (fromIntegral i * a)
    maybeTimes (VFloat f) (VAngle a) = pure $ VAngle (f * a)
    maybeTimes (VAngle a) (VFloat f) = pure $ VAngle (f * a)
    maybeTimes (VInteger i) (VFraction f) = pure $ VFraction (fromIntegral i * f)
    maybeTimes (VFraction f) (VInteger i) = pure $ VFraction (fromIntegral i * f)
    maybeTimes (VFloat x) (VFraction f) = pure $ VFraction (x * f)
    maybeTimes (VFraction f) (VFloat x) = pure $ VFraction (x * f)
    maybeTimes (VFraction f1) (VFraction f2) = pure $ VFraction (f1 * f2)
    maybeTimes (VRatio r1) (VRatio r2) = pure $ VRatio (r1 * r2)
    maybeTimes (VInteger i) (VRatio r) = pure $ VRatio (fromIntegral i * r)
    maybeTimes (VRatio r) (VInteger i) = pure $ VRatio (fromIntegral i * r)
    maybeTimes (VFloat x) (VRatio r) = pure $ VRatio (realToFrac x * r)
    maybeTimes (VRatio r) (VFloat x) = pure $ VRatio (realToFrac x * r)
    maybeTimes v1 v2 = fail $ "could not multiply " <> show v1 <> " and " <> show v2
  
    maybeDividedBy (VInteger i1) (VInteger i2) =
      if i1 `mod` i2 == 0
        then pure $ VInteger (i1 `div` i2)
        else pure $ VFloat (fromIntegral i1 / fromIntegral i2)
    maybeDividedBy (VFloat x1) (VFloat x2) = maybeTimes (VFloat x1) (VFloat (1 / x2))
    maybeDividedBy (VInteger i1) (VFloat f2) = pure $ VFloat (fromIntegral i1 / f2)
    maybeDividedBy (VFloat f1) (VInteger i2) = pure $ VFloat (f1 / fromIntegral i2)
    maybeDividedBy (VLength l) (VInteger i)
      | i >= 0 = pure $ VLength (mconcat $ replicate (fromIntegral i) l)
    maybeDividedBy (VLength l) (VFloat f) = pure $ VLength $ timesLength (1 / f) l
    maybeDividedBy (VAngle a) (VInteger i) = pure $ VAngle (fromIntegral i / a)
    maybeDividedBy (VInteger i) (VFraction f) = pure $ VFraction (fromIntegral i / f)
    maybeDividedBy (VFraction f) (VInteger i) = pure $ VFraction (fromIntegral i / f)
    maybeDividedBy (VFraction f1) (VFraction f2) = pure $ VFraction (f1 / f2)
    maybeDividedBy (VLength l1) (VLength l2)
      | l1 == l2 = pure $ VInteger 1
    maybeDividedBy (VLength (LExact l1 u1)) (VLength (LExact l2 u2))
      | u1 == u2 = pure $ VFloat (l1 / l2)
      | Just pts1 <- toPts u1 l1,
        Just pts2 <- toPts u2 l2 =
          pure $ VFloat (pts1 / pts2)
    maybeDividedBy (VLength (LRatio r)) x
      | Just (VRatio r') <- maybeDividedBy (VRatio r) x =
          pure $ VLength (LRatio r')
    maybeDividedBy (VRatio r1) (VLength (LRatio r2)) = pure $ VRatio (r1 / r2)
    maybeDividedBy (VAngle a1) (VAngle a2) = pure $ VFloat (a1 / a2)
    maybeDividedBy (VRatio a1) (VRatio a2) = pure $ VRatio (a1 / a2)
    maybeDividedBy (VRatio r) (VInteger i) = pure $ VRatio (r / fromIntegral i)
    maybeDividedBy (VRatio r) (VFloat x) =
      pure $ VRatio (r / realToFrac x)
    maybeDividedBy v1 v2 = fail $ "could not divide " <> show v1 <> " by " <> show v2
  
  data Content
    = Txt !Text
    | Lab !Text
    | Elt
        { eltName :: Identifier,
          eltPos :: Maybe SourcePos,
          eltFields :: M.Map Identifier Val
        }
    deriving (Show, Typeable)
  
  instance Eq Content where
    Txt t1 == Txt t2 = t1 == t2
    Lab t1 == Lab t2 = t1 == t2
    Elt n1 _ f1 == Elt n2 _ f2 = n1 == n2 && f1 == f2
    _ == _ = False
  
  instance Ord Content where
    compare Txt {} Lab {} = LT
    compare Lab {} Elt {} = LT
    compare Txt {} Elt {} = LT
    compare Lab {} Txt {} = GT
    compare Elt {} Lab {} = GT
    compare Elt {} Txt {} = GT
    compare (Txt t1) (Txt t2) = compare t1 t2
    compare (Lab t1) (Lab t2) = compare t1 t2
    compare (Elt n1 _ f1) (Elt n2 _ f2) = compare (n1, f1) (n2, f2)
  
  instance IsString Content where
    fromString x = Txt (T.pack x)
  
  newtype Function = Function (forall m. Monad m => Arguments -> MP m Val)
    deriving (Typeable)
  
  instance Show Function where
    show _ = "<function>"
  
  instance Eq Function where
    _ == _ = False
  
  data Scope
    = FunctionScope
    | BlockScope
    deriving (Show, Ord, Eq)
  
  data FlowDirective
    = FlowNormal
    | FlowBreak
    | FlowContinue
    | FlowReturn Bool
    deriving (Show, Ord, Eq)
  
  data Operations m =
    Operations
    { loadBytes :: FilePath -> m BS.ByteString
    , currentUTCTime :: m UTCTime
    , lookupEnvVar :: String -> m (Maybe String)
    , checkExistence :: FilePath -> m Bool
    }
  
  data EvalState m = EvalState
    { evalIdentifiers :: [(Scope, M.Map Identifier Val)],
      -- first item is current block, then superordinate block, etc.
      -- The standard identifiers and the identifiers that
      -- are imported by default into math contexts are special,
      -- since both can be overridden by user-defined identifiers.
      -- So, we store them separately.
      evalStandardIdentifiers :: [(Scope, M.Map Identifier Val)],
      evalMathIdentifiers :: [(Scope, M.Map Identifier Val)],
      evalCounters :: M.Map Counter Integer,
      evalMath :: Bool,
      evalShowRules :: [ShowRule],
      evalNextShowRuleIdentifier :: Int,
      evalStyles :: M.Map Identifier Arguments,
      evalFlowDirective :: FlowDirective,
      evalPackageRoot :: FilePath,
      evalLocalDir :: FilePath,
      evalOperations :: Operations m
    }
  
  emptyEvalState :: EvalState m
  emptyEvalState = EvalState
      { evalIdentifiers = [],
        evalStandardIdentifiers = [],
        evalMathIdentifiers = [],
        evalCounters = mempty,
        evalMath = False,
        evalShowRules = [],
        evalNextShowRuleIdentifier = 1,
        evalStyles = mempty,
        evalFlowDirective = FlowNormal,
        evalPackageRoot = mempty,
        evalLocalDir = mempty,
        evalOperations = undefined
      }
  
  data Attempt a
    = Success a
    | Failure String
    deriving (Show, Eq, Ord, Typeable)
  
  instance Functor Attempt where
    fmap f (Success x) = Success (f x)
    fmap _ (Failure s) = Failure s
  
  instance Applicative Attempt where
    pure = Success
    (Success f) <*> (Success a) = Success (f a)
    Failure s <*> _ = Failure s
    _ <*> Failure s = Failure s
  
  instance Monad Attempt where
    return = pure
    Failure s >>= _ = Failure s
    Success x >>= f = f x
  
  instance MonadFail Attempt where
    fail = Failure
  
  data ShowRule
    = ShowRule Int Selector (forall m. Monad m => Content -> MP m (Seq Content))
  
  instance Show ShowRule where
    show (ShowRule ident sel _) =
      "ShowRule " <> show ident <> " " <> show sel <> " <function>"
  
  instance Eq ShowRule where
    (ShowRule id1 _ _) == (ShowRule id2 _ _) = id1 == id2
  
  type MP m = ParsecT [Markup] (EvalState m) m
  
  data Arguments = Arguments
    { positional :: [Val],
      named :: OM.OMap Identifier Val
    }
    deriving (Show, Eq, Typeable)
  
  instance Semigroup Arguments where
    Arguments ps1 ns1 <> Arguments ps2 ns2 =
      Arguments (combinePositional ps1 ps2) (OM.unionWithR (\_ _ v -> v) ns1 ns2)
  
  -- we want to let a later alignment, color, or length supersede rather than
  -- adding to an earlier one. For #set.
  combinePositional :: [Val] -> [Val] -> [Val]
  combinePositional [] ys = ys
  combinePositional xs (y : ys) =
    case (valType y, valType (last xs)) of
      (TAlignment, TAlignment) -> init xs ++ y : ys
      (TLength, TLength) -> init xs ++ y : ys
      (TAngle, TAngle) -> init xs ++ y : ys
      (TColor, TColor) -> init xs ++ y : ys
      _ -> xs ++ y : ys
  combinePositional xs ys = xs ++ ys
  
  instance Monoid Arguments where
    mappend = (<>)
    mempty :: Arguments
    mempty = Arguments mempty OM.empty
  
  getPositionalArg :: (MonadFail m, MonadPlus m, FromVal a) => Int -> Arguments -> m a
  getPositionalArg idx args =
    if length (positional args) < idx
      then fail "Not enough arguments"
      else fromVal (positional args !! (idx - 1))
  
  getNamedArg :: (MonadFail m, MonadPlus m, FromVal a) => Identifier -> Arguments -> m a
  getNamedArg ident@(Identifier name) args =
    case OM.lookup ident (named args) of
      Nothing -> fail $ "No argument named " <> T.unpack name
      Just v -> fromVal v
  
  data Counter
    = CounterCustom !Text
    | CounterLabel !Text
    | CounterSelector !Selector
    | CounterPage
    deriving (Eq, Ord, Show, Typeable)
  
  data LUnit = LEm | LPt | LIn | LCm | LMm
    deriving (Show, Eq, Typeable)
  
  data Length
    = LExact Double LUnit
    | LRatio !Rational
    | LSum Length Length
    deriving (Show, Eq, Typeable)
  
  instance Semigroup Length where
    (LExact x xu) <> (LExact y yu)
      | Just (z, zu) <- addLengths (x, xu) (y, yu) =
          LExact z zu
    LRatio x <> LRatio y = LRatio (x + y)
    LRatio x <> LExact 0 _ = LRatio x
    LExact 0 _ <> LRatio x = LRatio x
    LRatio 0 <> LExact x u = LExact x u
    LExact x u <> LRatio 0 = LExact x u
    x <> y = LSum x y
  
  instance Monoid Length where
    mappend = (<>)
    mempty = LExact 0.0 LPt
  
  addLengths :: (Double, LUnit) -> (Double, LUnit) -> Maybe (Double, LUnit)
  addLengths (0, _xu) (y, yu) = pure (y, yu)
  addLengths (x, xu) (0, _yu) = pure (x, xu)
  addLengths (x, xu) (y, yu) =
    if xu == yu
      then pure (x + y, xu)
      else do
        x' <- toPts xu x
        y' <- toPts yu y
        pure (x' + y', LPt)
  
  timesLength :: Double -> Length -> Length
  timesLength f (LExact l u) = LExact (f * l) u
  timesLength f (LRatio r) = LRatio (toRational f * r)
  timesLength f (LSum l1 l2) = LSum (timesLength f l1) (timesLength f l2)
  
  toPts :: LUnit -> Double -> Maybe Double
  toPts LPt x = Just x
  toPts LEm _ = Nothing
  toPts LIn x = Just $ x * 72.0
  toPts LCm x = Just $ x * 28.35
  toPts LMm x = Just $ x * 283.5
  
  -- boolean is true if we need to include parens for LSum
  renderLength :: Bool -> Length -> Text
  renderLength parens (LSum l1 l2) =
    (if parens then (\x -> "(" <> x <> ")") else id)
      (renderLength True l1 <> " + " <> renderLength True l2)
  renderLength _ (LExact x u) =
    T.pack (show x) <> renderUnit u
  renderLength _ (LRatio x) = toPercent x
  
  renderUnit :: LUnit -> Text
  renderUnit LEm = "em"
  renderUnit LPt = "pt"
  renderUnit LIn = "in"
  renderUnit LCm = "cm"
  renderUnit LMm = "mm"
  
  compareLength :: Length -> Length -> Maybe Ordering
  compareLength (LExact x xu) (LExact y yu)
    | xu == yu = pure $ compare x y
    | otherwise = do
        x' <- toPts xu x
        y' <- toPts yu y
        pure $ compare x' y'
  compareLength (LRatio x) (LRatio y) = pure (compare x y)
  compareLength (LSum x1 y1) (LSum x2 y2) = do
    z <- compareLength x1 x2
    if z == EQ
      then compareLength y1 y2
      else mzero
  compareLength _ _ = mzero
  
  negateLength :: Length -> Length
  negateLength (LExact x u) = LExact (negate x) u
  negateLength (LRatio x) = LRatio (negate x)
  negateLength (LSum x y) = LSum (negateLength x) (negateLength y)
  
  data Horiz = HorizStart | HorizEnd | HorizLeft | HorizCenter | HorizRight
    deriving (Show, Eq, Ord, Typeable)
  
  data Vert = VertTop | VertHorizon | VertBottom
    deriving (Show, Eq, Ord, Typeable)
  
  data Color
    = RGB Rational Rational Rational Rational
    | CMYK Rational Rational Rational Rational
    | Luma Rational
    deriving (Show, Eq, Ord, Typeable)
  
  data Direction 
    = Ltr -- ^ Left to right
    | Rtl -- ^ Right to left
    | Ttb -- ^ Top to bottom
    | Btt -- ^ Bottom to top
    deriving (Show, Eq, Ord, Typeable)
  
  prettyVal :: Val -> P.Doc
  prettyVal expr =
    case expr of
      VContent cs -> prettyContent cs
      VString t -> "\"" <> escString t <> "\""
      VRegex re -> P.text (show re)
      VDateTime d t -> P.text (unwords (catMaybes
         [show <$> d, formatTime defaultTimeLocale "%0H:%0M:%0S" <$> t]))
      VAuto -> "auto"
      VNone -> "none"
      VBoolean True -> "true"
      VBoolean False -> "false"
      VFloat x -> P.text $ show x
      VRatio x -> text $ toPercent x
      VInteger x -> P.text $ show x
      VAngle x -> P.text (show x <> "deg")
      VLength len -> text $ renderLength False len
      VAlignment x y -> text $
        case (x, y) of
          (Nothing, Nothing) -> mempty
          (Just x', Nothing) -> renderHoriz x'
          (Nothing, Just y') -> renderVert y'
          (Just x', Just y') ->
            "Axes(" <> renderHoriz x' <> ", " <> renderVert y' <> ")"
        where
          renderHoriz = T.toLower . T.drop 5 . T.pack . show
          renderVert = T.toLower . T.drop 4 . T.pack . show
      VFraction x -> P.text (show x <> "fr")
      VArray xs ->
        P.parens
          ( P.cat $
              P.punctuate ", " $
                map prettyVal (V.toList xs)
          )
      VTermItem t d -> prettyVal (VArray [VContent t, VContent d])
      VDict m ->
        P.parens
          ( P.sep $
              P.punctuate "," $
                ( map
                    ( \(Identifier k, v) ->
                        text k <> ": " <> prettyVal v
                    )
                    (OM.assocs m)
                )
          )
      VDirection d -> text $ T.toLower $ T.pack $ show d
      VFunction _ _ _ -> mempty
      VLabel t -> text $ "<" <> t <> ">"
      VCounter _ -> mempty
      VColor (RGB r g b o) ->
        "rgb("
          <> text (toPercent r)
          <> ","
          <> text (toPercent g)
          <> ","
          <> text (toPercent b)
          <> ","
          <> text (toPercent o)
          <> ")"
      VColor (CMYK c m y k) ->
        "cmyk("
          <> text (toPercent c)
          <> ","
          <> text (toPercent m)
          <> ","
          <> text (toPercent y)
          <> ","
          <> text (toPercent k)
          <> ")"
      VColor (Luma g) -> "luma(" <> text (toPercent g) <> ")"
      VModule (Identifier modid) _ -> "<module " <> text modid <> ">"
      VArguments args ->
        P.parens
          ( P.sep
              ( P.punctuate
                  ","
                  ( [ P.sep
                        ( P.punctuate
                            ","
                            ( map
                                ( \(Identifier k, v) ->
                                    text k <> ": " <> prettyVal v
                                )
                                (OM.assocs (named args))
                            )
                        )
                      | not (OM.null (named args))
                    ]
                      ++ [ P.cat (P.punctuate ", " $ map prettyVal (positional args))
                           | not (null (positional args))
                         ]
                  )
              )
          )
      VSymbol (Symbol t _ _) -> text t
      VSelector _ -> mempty
      VStyles -> mempty
      VVersion xs -> text $ T.intercalate "." (map (T.pack . show) xs)
      VBytes bs -> text $ "bytes(" <> T.pack (show (BS.length bs)) <> ")"
      VType ty -> text $ prettyType ty
  
  prettyType :: ValType -> Text
  prettyType TDict = "dictionary"
  prettyType TInteger = "int"
  prettyType x = T.toLower . T.pack . drop 1 . show $ x
  
  escString :: Text -> P.Doc
  escString =
    P.text . concatMap go . T.unpack
    where
      go :: Char -> String
      go '"' = "\\\""
      go '\\' = "\\\\"
      go '\n' = "\\n"
      go '\r' = "\\r"
      go '\t' = "\\t"
      go x = [x]
  
  prettyContent :: Seq Content -> P.Doc
  prettyContent cs
    | Seq.length cs == 1 = foldMap go cs
    | otherwise =
        P.braces
          ( P.space
              <> P.cat (P.punctuate ", " (map go (F.toList cs)))
              <> P.space
          )
    where
      go (Txt t) = "[" <> text t <> "]"
      go (Lab l) = "<" <> text l <> ">"
      go (Elt (Identifier name) _ fields) =
        text name
          <> P.parens
            ( P.cat $
                P.punctuate
                  ", "
                  ( map
                      ( \(Identifier k, v) ->
                          text k <> ": " <> prettyVal v
                      )
                      (M.toList fields)
                  )
            )
  
  valToContent :: Val -> Seq Content
  valToContent (VContent x) = x
  valToContent VNone = mempty
  valToContent (VString t) = Seq.singleton $ Txt t
  valToContent (VLabel t) = Seq.singleton $ Lab t
  valToContent x = Seq.singleton $ Txt $ repr x
  
  renderStyle :: P.Style
  renderStyle = P.Style P.PageMode 60 2.0
  
  repr :: Val -> Text
  repr = T.pack . P.renderStyle renderStyle . prettyVal
  
  toPercent :: Rational -> Text
  toPercent n =
    T.pack (show (floor (100 * n) :: Integer)) <> "%"
  
  text :: Text -> P.Doc
  text t = P.text $ T.unpack t
  
  lookupIdentifier :: Monad m => Identifier -> MP m Val
  lookupIdentifier ident = do
    let go [] = fail $ show ident <> " not found"
        go ((_, i) : is) = case M.lookup ident i of
          Just v -> pure v
          Nothing -> go is
    identifiers <- evalIdentifiers <$> getState
    mathIdentifiers <- evalMathIdentifiers <$> getState
    standardIdentifiers <- evalStandardIdentifiers <$> getState
    math <- evalMath <$> getState
    go $ case identifiers of
           -- in math mode, we insert the sym and math modules right before
           -- the final module (standard module)
           (_:_) | math -> identifiers ++ mathIdentifiers ++ standardIdentifiers
           _ -> identifiers ++ standardIdentifiers
  