{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE CPP #-}

module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where

import           IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString.Lazy as LBS

import           Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import           Data.Char (isSpace)
import qualified Data.Vector as V
import qualified Data.List as List

import           IHaskell.Flags (LhsStyle(LhsStyle))

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Aeson.Key as Key
#else
#endif

lhsToIpynb :: LhsStyle LText -> FilePath -> FilePath -> IO ()
lhsToIpynb :: LhsStyle LText -> FilePath -> FilePath -> IO ()
lhsToIpynb LhsStyle LText
sty FilePath
from FilePath
to = do
  [CellLine LText]
classed <- LhsStyle LText -> [LText] -> [CellLine LText]
classifyLines LhsStyle LText
sty forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> [LText]
LT.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> LText
LT.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile FilePath
from
  FilePath -> ByteString -> IO ()
LBS.writeFile FilePath
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Cell [LText]] -> Value
encodeCells forall a b. (a -> b) -> a -> b
$ [CellLine LText] -> [Cell [LText]]
groupClassified [CellLine LText]
classed

data CellLine a = CodeLine a
                | OutputLine a
                | MarkdownLine a
  deriving Int -> CellLine a -> ShowS
forall a. Show a => Int -> CellLine a -> ShowS
forall a. Show a => [CellLine a] -> ShowS
forall a. Show a => CellLine a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CellLine a] -> ShowS
$cshowList :: forall a. Show a => [CellLine a] -> ShowS
show :: CellLine a -> FilePath
$cshow :: forall a. Show a => CellLine a -> FilePath
showsPrec :: Int -> CellLine a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> CellLine a -> ShowS
Show

isCode :: CellLine t -> Bool
isCode :: forall t. CellLine t -> Bool
isCode (CodeLine t
_) = Bool
True
isCode CellLine t
_ = Bool
False

isOutput :: CellLine t -> Bool
isOutput :: forall t. CellLine t -> Bool
isOutput (OutputLine t
_) = Bool
True
isOutput CellLine t
_ = Bool
False

isMD :: CellLine t -> Bool
isMD :: forall t. CellLine t -> Bool
isMD (MarkdownLine t
_) = Bool
True
isMD CellLine t
_ = Bool
False

isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD :: forall a. (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD (MarkdownLine a
a) = a
a forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty
isEmptyMD CellLine a
_ = Bool
False

untag :: CellLine t -> t
untag :: forall t. CellLine t -> t
untag (CodeLine t
a) = t
a
untag (OutputLine t
a) = t
a
untag (MarkdownLine t
a) = t
a

data Cell a = Code a a
            | Markdown a
  deriving Int -> Cell a -> ShowS
forall a. Show a => Int -> Cell a -> ShowS
forall a. Show a => [Cell a] -> ShowS
forall a. Show a => Cell a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Cell a] -> ShowS
$cshowList :: forall a. Show a => [Cell a] -> ShowS
show :: Cell a -> FilePath
$cshow :: forall a. Show a => Cell a -> FilePath
showsPrec :: Int -> Cell a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Cell a -> ShowS
Show

encodeCells :: [Cell [LText]] -> Value
encodeCells :: [Cell [LText]] -> Value
encodeCells [Cell [LText]]
xs = [(Key, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$
  Key
"cells" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Array -> Value
Array (forall a. [a] -> Vector a
V.fromList (forall a b. (a -> b) -> [a] -> [b]
map Cell [LText] -> Value
cellToVal [Cell [LText]]
xs)) forall a. a -> [a] -> [a]
: [(Key, Value)]
boilerplate

cellToVal :: Cell [LText] -> Value
cellToVal :: Cell [LText] -> Value
cellToVal (Code [LText]
i [LText]
o) = [(Key, Value)] -> Value
object
                         [ Key
"cell_type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"code"
                         , Key
"execution_count" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
Null
                         , Key
"metadata" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [Key
"collapsed" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool -> Value
Bool Bool
False]
                         , Key
"source" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [LText] -> Value
arrayFromTxt [LText]
i
                         , Key
"outputs" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Array -> Value
Array
                                          (forall a. [a] -> Vector a
V.fromList
                                             [[(Key, Value)] -> Value
object
                                                [ Key
"text" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [LText] -> Value
arrayFromTxt [LText]
o
                                                , Key
"metadata" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object []
                                                , Key
"output_type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"display_data"
                                                ] | LText
_ <- forall a. Int -> [a] -> [a]
take Int
1 [LText]
o])
                         ]
cellToVal (Markdown [LText]
txt) = [(Key, Value)] -> Value
object
                             [ Key
"cell_type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"markdown"
                             , Key
"metadata" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [Key
"hidden" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool -> Value
Bool Bool
False]
                             , Key
"source" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [LText] -> Value
arrayFromTxt [LText]
txt
                             ]

-- | arrayFromTxt makes a JSON array of string s
arrayFromTxt :: [LText] -> Value
arrayFromTxt :: [LText] -> Value
arrayFromTxt [LText]
i = Array -> Value
Array (forall a. [a] -> Vector a
V.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map LText -> Value
stringify [LText]
i)
  where
    stringify :: LText -> Value
stringify = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> Text
LT.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip LText -> Char -> LText
LT.snoc Char
'\n'

-- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and
-- output correctly.
#if MIN_VERSION_aeson(2,0,0)
boilerplate :: [(Key.Key, Value)]
#else
boilerplate :: [(T.Text, Value)]
#endif
boilerplate :: [(Key, Value)]
boilerplate =
  [Key
"metadata" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [(Key, Value)
kernelspec, (Key, Value)
lang], Key
"nbformat" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Scientific -> Value
Number Scientific
4, Key
"nbformat_minor" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Scientific -> Value
Number Scientific
0]
  where
    kernelspec :: (Key, Value)
kernelspec = Key
"kernelspec" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object
                                   [ Key
"display_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"Haskell"
                                   , Key
"language" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"haskell"
                                   , Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"haskell"
                                   ]
    lang :: (Key, Value)
lang = Key
"language_info" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object [Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"haskell", Key
"version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String VERSION_ghc]

groupClassified :: [CellLine LText] -> [Cell [LText]]
groupClassified :: [CellLine LText] -> [Cell [LText]]
groupClassified (CodeLine LText
a:[CellLine LText]
x)
  | ([CellLine LText]
c, [CellLine LText]
x1) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span forall t. CellLine t -> Bool
isCode [CellLine LText]
x,
    ([CellLine LText]
_, [CellLine LText]
x2) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span forall a. (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD [CellLine LText]
x1,
    ([CellLine LText]
o, [CellLine LText]
x3) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span forall t. CellLine t -> Bool
isOutput [CellLine LText]
x2
  = forall a. a -> a -> Cell a
Code (LText
a forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall t. CellLine t -> t
untag [CellLine LText]
c) (forall a b. (a -> b) -> [a] -> [b]
map forall t. CellLine t -> t
untag [CellLine LText]
o) forall a. a -> [a] -> [a]
: [CellLine LText] -> [Cell [LText]]
groupClassified [CellLine LText]
x3
groupClassified (MarkdownLine LText
a:[CellLine LText]
x)
  | ([CellLine LText]
m, [CellLine LText]
x1) <- forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span forall t. CellLine t -> Bool
isMD [CellLine LText]
x = forall a. a -> Cell a
Markdown (LText
a forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall t. CellLine t -> t
untag [CellLine LText]
m) forall a. a -> [a] -> [a]
: [CellLine LText] -> [Cell [LText]]
groupClassified [CellLine LText]
x1
groupClassified (OutputLine LText
a:[CellLine LText]
x) = forall a. a -> Cell a
Markdown [LText
a] forall a. a -> [a] -> [a]
: [CellLine LText] -> [Cell [LText]]
groupClassified [CellLine LText]
x
groupClassified [] = []

classifyLines :: LhsStyle LText -> [LText] -> [CellLine LText]
classifyLines :: LhsStyle LText -> [LText] -> [CellLine LText]
classifyLines sty :: LhsStyle LText
sty@(LhsStyle LText
c LText
o LText
_ LText
_ LText
_ LText
_) (LText
l:[LText]
ls) =
  case (LText -> Maybe LText
sp LText
c, LText -> Maybe LText
sp LText
o) of
    (Just LText
a, Maybe LText
Nothing)  -> forall a. a -> CellLine a
CodeLine LText
a forall a. a -> [a] -> [a]
: LhsStyle LText -> [LText] -> [CellLine LText]
classifyLines LhsStyle LText
sty [LText]
ls
    (Maybe LText
Nothing, Just LText
a)  -> forall a. a -> CellLine a
OutputLine LText
a forall a. a -> [a] -> [a]
: LhsStyle LText -> [LText] -> [CellLine LText]
classifyLines LhsStyle LText
sty [LText]
ls
    (Maybe LText
Nothing, Maybe LText
Nothing) -> forall a. a -> CellLine a
MarkdownLine LText
l forall a. a -> [a] -> [a]
: LhsStyle LText -> [LText] -> [CellLine LText]
classifyLines LhsStyle LText
sty [LText]
ls
    (Maybe LText, Maybe LText)
_                  -> forall a. HasCallStack => FilePath -> a
error FilePath
"IHaskell.Convert.classifyLines"
  where
    sp :: LText -> Maybe LText
sp LText
x = LText -> LText -> Maybe LText
LT.stripPrefix (LText -> LText
dropSpace LText
x) (LText -> LText
dropSpace LText
l) forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {a}. IsString a => LText -> Maybe a
blankCodeLine LText
x
    blankCodeLine :: LText -> Maybe a
blankCodeLine LText
x = if LText -> LText
LT.strip LText
x forall a. Eq a => a -> a -> Bool
== LText -> LText
LT.strip LText
l
                        then forall a. a -> Maybe a
Just a
""
                        else forall a. Maybe a
Nothing
    dropSpace :: LText -> LText
dropSpace = (Char -> Bool) -> LText -> LText
LT.dropWhile Char -> Bool
isSpace
classifyLines LhsStyle LText
_ [] = []