aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Lua/SharedInstances.hs
blob: 3d2d29ebf2a4cfb8c2e08fd9e7d435bb4c1003ed (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-
Copyright © 2012-2016 John MacFarlane <jgm@berkeley.edu>
            2017 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
   Module      : Text.Pandoc.Lua.SharedInstances
   Copyright   : © 2012–2016 John MacFarlane,
                 © 2017 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb+pandoc@moltkeplatz.de>
   Stability   : alpha

Shared StackValue instances for pandoc and generic types.
-}
module Text.Pandoc.Lua.SharedInstances () where

import Scripting.Lua ( LTYPE(..), StackValue(..), newtable )
import Text.Pandoc.Lua.Util ( addRawInt, addValue, getRawInt, keyValuePairs )

import qualified Data.Map as M
import qualified Text.Pandoc.UTF8 as UTF8

#if MIN_VERSION_base(4,8,0)
instance {-# OVERLAPS #-} StackValue [Char] where
#else
instance StackValue [Char] where
#endif
  push lua cs = push lua (UTF8.fromString cs)
  peek lua i = fmap UTF8.toString <$> peek lua i
  valuetype _ = TSTRING

instance (StackValue a, StackValue b) => StackValue (a, b) where
  push lua (a, b) = do
    newtable lua
    addRawInt lua 1 a
    addRawInt lua 2 b
  peek lua idx = do
    a <- getRawInt lua idx 1
    b <- getRawInt lua idx 2
    return $ (,) <$> a <*> b
  valuetype _ = TTABLE

instance (StackValue a, StackValue b, StackValue c) =>
         StackValue (a, b, c)
 where
  push lua (a, b, c) = do
    newtable lua
    addRawInt lua 1 a
    addRawInt lua 2 b
    addRawInt lua 3 c
  peek lua idx = do
    a <- getRawInt lua idx 1
    b <- getRawInt lua idx 2
    c <- getRawInt lua idx 3
    return $ (,,) <$> a <*> b <*> c
  valuetype _ = TTABLE

instance (StackValue a, StackValue b, StackValue c,
          StackValue d, StackValue e) =>
         StackValue (a, b, c, d, e)
 where
  push lua (a, b, c, d, e) = do
    newtable lua
    addRawInt lua 1 a
    addRawInt lua 2 b
    addRawInt lua 3 c
    addRawInt lua 4 d
    addRawInt lua 5 e
  peek lua idx = do
    a <- getRawInt lua idx 1
    b <- getRawInt lua idx 2
    c <- getRawInt lua idx 3
    d <- getRawInt lua idx 4
    e <- getRawInt lua idx 5
    return $ (,,,,) <$> a <*> b <*> c <*> d <*> e
  valuetype _ = TTABLE

instance (Ord a, StackValue a, StackValue b) =>
         StackValue (M.Map a b) where
  push lua m = do
    newtable lua
    mapM_ (uncurry $ addValue lua) $ M.toList m
  peek lua idx = fmap M.fromList <$> keyValuePairs lua idx
  valuetype _ = TTABLE

instance (StackValue a, StackValue b) => StackValue (Either a b) where
  push lua = \case
    Left x -> push lua x
    Right x -> push lua x
  peek lua idx = peek lua idx >>= \case
      Just left -> return . Just $ Left left
      Nothing   -> fmap Right <$> peek lua idx
  valuetype (Left x) = valuetype x
  valuetype (Right x) = valuetype x