Update

Update

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Monad.Eff (Eff, forE)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
--import Data.List
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

vertices :: Array Point3D
vertices = [
    Point3D (-100.0) 100.0 (-100.0)
    ,Point3D 100.0 100.0 (-100.0)
    ,Point3D 100.0 (-100.0) (-100.0)
    ,Point3D (-100.0) (-100.0) (-100.0)
    ,Point3D (-100.0) 100.0 100.0
    ,Point3D 100.0 100.0 100.0
    ,Point3D 100.0 (-100.0) 100.0
    ,Point3D (-100.0) (-100.0) 100.0
]

data Point3D = Point3D Number Number Number

data Angle3D = Angle3D
    {qx :: Number
    ,qy :: Number
    ,qz :: Number
    }

angle :: Angle3D
angle = Angle3D
    {qx: Math.pi/4.0
    ,qy: Math.pi/3.0
    ,qz: Math.pi/4.0
    }

data Face = Face Point3D Point3D Point3D Point3D

faces :: Array (Array Int)
faces = [
    [0,1,2,3],
    [1,5,6,2],
    [5,4,7,6],
    [4,0,3,7],
    [0,4,5,1],
    [3,2,6,7]
]

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D x y z) (Angle3D ang) =
    let xRotQz = x * Math.cos ang.qz + y * Math.sin ang.qz
        yRotQz = y * Math.cos ang.qz + x * Math.sin ang.qz
        zRotQz = z
        xRotQzQx = xRotQz
        yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
        zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
        xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
        yRotQzQxQy = yRotQzQx
    in
        (Point3D xRotQzQxQy yRotQzQxQy zRotQz)

projectAll3Dto2D :: (Array Point3D) -> Angle3D -> (Array Point3D)
projectAll3Dto2D vert3D ang =
    let
        vert2D = map (\v -> project3Dto2D v ang ) vert3D
    in
        vert2D

defVal1 :: Maybe Number -> Number
defVal1 val = fromMaybe 0.0 val

{-
defVal :: Maybe Point3D -> Point3D
defVal (Point3D x y z) =
    let
        dx = fromMaybe 0.0 x
        dy = fromMaybe 0.0 y
        dz = fromMaybe 0.0 z
    in
        (Point3D dx dy dz)
-}

drawFace :: forall e. Context2D -> Face -> Eff (canvas :: CANVAS | e) Unit
drawFace ctx (Face v1 v2 v3 v4) = strokePath ctx do
        ctx <- setStrokeStyle "#000000" ctx
        ctx <- moveTo ctx x1 y1
        ctx <- lineTo ctx x2 y2
        ctx <- lineTo ctx x3 y3
        ctx <- lineTo ctx x4 y4
        void $ closePath ctx
    where
        Point3D x1 y1 z1 = v1
        Point3D x2 y2 z2 = v2
        Point3D x3 y3 z3 = v3
        Point3D x4 y4 z4 = v4

drawCube :: forall e. Context2D -> (Array Point3D) -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx vert3D = strokePath ctx do
    for_ faces $ \face -> do
        drawFace ctx Face(v1 v2 v3 v4)
        where
            v1 = vert2D(face !! 0)
            v2 = vert2D(face !! 1)
            v3 = vert2D(face !! 2)
            v4 = vert2D(face !! 3)
            Face v1 v2 v3 v4 = v1 v2 v3 v4
    where
        vert2D = projectAll3Dto2D vert3D angle

transform :: Point3D -> Point3D
transform (Point3D x y z) =
    let nx = x + 200.0
        ny = x + 200.0
    in
        (Point3D nx ny z)

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, console :: CONSOLE, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
    Just canvas <- getCanvasElementById "thecanvas"
    ctx <- getContext2D canvas
    animFrame <- animationFrame
    ctx <- setFillStyle "#0000FF" ctx
    --ctx <- fillRect{x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
    drawCube ctx vertices
    --log("working")

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Monad.Eff (Eff, forE)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
--import Data.List
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

vertices :: Array Point3D
vertices =
    [Point3D (-100.0) 100.0 (-100.0)
    ,Point3D 100.0 100.0 (-100.0)
    ,Point3D 100.0 (-100.0) (-100.0)
    ,Point3D (-100.0) (-100.0) (-100.0)
    ,Point3D (-100.0) 100.0 100.0
    ,Point3D 100.0 100.0 100.0
    ,Point3D 100.0 (-100.0) 100.0
    ,Point3D (-100.0) (-100.0) 100.0
  ]

data Point3D = Point3D Number Number Number

data Angle3D = Angle3D
    {qx :: Number
    ,qy :: Number
    ,qz :: Number
    }

angle :: Angle3D
angle = Angle3D
    {qx: Math.pi/4.0
    ,qy: Math.pi/3.0
    ,qz: Math.pi/4.0
    }

data Face = Face Point3D Point3D Point3D Point3D

faces :: Array (Array Int)
faces = [
    [0,1,2,3],
    [1,5,6,2],
    [5,4,7,6],
    [4,0,3,7],
    [0,4,5,1],
    [3,2,6,7]
]

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D x y z) (Angle3D ang) =
    let xRotQz = x * Math.cos ang.qz + y * Math.sin ang.qz
        yRotQz = y * Math.cos ang.qz + x * Math.sin ang.qz
        zRotQz = z
        xRotQzQx = xRotQz
        yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
        zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
        xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
        yRotQzQxQy = yRotQzQx
    in
        (Point3D xRotQzQxQy yRotQzQxQy zRotQz)

projectAll3Dto2D :: (Array Point3D) -> Angle3D -> (Array Point3D)
projectAll3Dto2D vert3D ang =
    let
        vert2D = map (\v -> project3Dto2D v ang ) vert3D
    in
        vert2D

defVal1 :: Maybe Number -> Number
defVal1 val = fromMaybe 0.0 val

{-
defVal :: Maybe Point3D -> Point3D
defVal (Point3D x y z) =
    let
        dx = fromMaybe 0.0 x
        dy = fromMaybe 0.0 y
        dz = fromMaybe 0.0 z
    in
        (Point3D dx dy dz)
-}

drawFace :: forall e. Context2D -> Face -> Eff (canvas :: CANVAS | e) Unit
drawFace ctx (Face v1 v2 v3 v4) = strokePath ctx do
        ctx <- setStrokeStyle "#000000" ctx
        ctx <- moveTo ctx x1 y1
        ctx <- lineTo ctx x2 y2
        ctx <- lineTo ctx x3 y3
        ctx <- lineTo ctx x4 y4
        void $ closePath ctx
    where
        Point3D x1 y1 z1 = v1
        Point3D x2 y2 z2 = v2
        Point3D x3 y3 z3 = v3
        Point3D x4 y4 z4 = v4

drawCube :: forall e. Context2D -> (Array Point3D) -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx vert3D = strokePath ctx do
    --for faces $ \face -> do
    --  drawFace (map vert2D face)
    void $ forE 0 6 $ \i -> do
        let face = faces !! i
        let vertFace = []
        void $ forE 0 4 $ \j -> do
            cons (vert2D (face !! j)) vertFace
        drawFace vertFace
    where
        vert2D = projectAll3Dto2D vert3D angle

transform :: Point3D -> Point3D
transform (Point3D x y z) =
    let nx = x + 200.0
        ny = x + 200.0
    in
        (Point3D nx ny z)

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, console :: CONSOLE, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
    Just canvas <- getCanvasElementById "thecanvas"
    ctx <- getContext2D canvas
    animFrame <- animationFrame
    ctx <- setFillStyle "#0000FF" ctx
    --ctx <- fillRect{x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
    drawCube ctx vertices
    --log("working")


move nav

move nav

module Main where

import Prelude hiding (div)
import Data.List (List, length, (!!))
import Data.Maybe(Maybe(..))
import Data.Either (Either(..))
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, br, p)
import Text.Smolder.Markup (text, (#!))
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)
import Content.Render (render)

data Event = Next | Previous | Restart

slideSource :: String
slideSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""

load :: String -> Either String (List SlamDown)
load src = map slides (parseMd src)

type State = {
  index :: Int,
  maybePresentation :: Either String (List SlamDown)
}

initialState :: State
initialState = { index: 1, maybePresentation: load slideSource }

numSlides :: State -> Int
numSlides { index: _, maybePresentation: Left err} = 0
numSlides { index: _, maybePresentation: Right ss} = length ss

renderSlide :: forall b. Int -> List SlamDown -> HTML b
renderSlide index slides = case slides !! (index - 1) of
   Nothing -> div $ p $ text "Out of range"
   Just md -> render md

content :: forall a. State -> HTML a
content { index: _, maybePresentation: Left err} = div $ p $ text $ "No slides. " <> err
content { index: i, maybePresentation: Right ss} = renderSlide i ss

foldp :: ∀ fx. Event -> State -> EffModel State Event fx
foldp Next s = { state: s {index = if s.index >= numSlides s then numSlides s else s.index + 1 }, effects: [] }
foldp Previous s  = { state: s { index =  if s.index <= 1 then 1 else s.index - 1 }, effects: [] }
foldp Restart s = { state: initialState, effects: [] }

view :: State -> HTML Event
view state =
  div do
    button #! onClick (const Previous) $ text "Previous"
    button #! onClick (const Next) $ text "Next"
    button #! onClick (const Restart) $ text "Restart"
    br
    div $ text $ "Slide " <> (show state.index) <> "/" <> show (numSlides state)
    br
    content state

main :: ∀ fx. Eff (CoreEffects fx) Unit
main = do
  app <- start
    { initialState
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input

module Main where

import Prelude hiding (div)
import Data.List (List, length, (!!))
import Data.Maybe(Maybe(..))
import Data.Either (Either(..))
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, br, p)
import Text.Smolder.Markup (text, (#!))
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)
import Content.Render (render)

data Event = Next | Previous | Restart

slideSource :: String
slideSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""

load :: String -> Either String (List SlamDown)
load src = map slides (parseMd src)

type State = {
  index :: Int,
  maybePresentation :: Either String (List SlamDown)
}

initialState :: State
initialState = { index: 1, maybePresentation: load slideSource }

numSlides :: State -> Int
numSlides { index: _, maybePresentation: Left err} = 0
numSlides { index: _, maybePresentation: Right ss} = length ss

renderSlide :: forall b. Int -> List SlamDown -> HTML b
renderSlide index slides = case slides !! (index - 1) of
   Nothing -> div $ p $ text "Out of range"
   Just md -> render md

content :: forall a. State -> HTML a
content { index: _, maybePresentation: Left err} = div $ p $ text $ "No slides. " <> err
content { index: i, maybePresentation: Right ss} = renderSlide i ss

foldp :: ∀ fx. Event -> State -> EffModel State Event fx
foldp Next s = { state: s {index = if s.index >= numSlides s then numSlides s else s.index + 1 }, effects: [] }
foldp Previous s  = { state: s { index =  if s.index <= 1 then 1 else s.index - 1 }, effects: [] }
foldp Restart s = { state: initialState, effects: [] }

view :: State -> HTML Event
view state =
  div do
    content state
    div $ text $ "Slide " <> (show state.index)
    br
    button #! onClick (const Previous) $ text "Previous"
    button #! onClick (const Next) $ text "Next"
    button #! onClick (const Restart) $ text "Restart"

main :: ∀ fx. Eff (CoreEffects fx) Unit
main = do
  app <- start
    { initialState
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input


Break execution context

Break execution context

Refer: https://github.com/owickstrom/purescript-spec/issues/24

module Test.Spec.CompatSpec (genCompatSpec) where

import Prelude
import Debug.Trace
import Global (readFloat, readInt)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Aff (Aff(), liftEff', later)
import Control.Monad.Trans (lift)
import Data.List (List(..), toList, concat, last, init)
import Text.Parsing.Parser as P
import Data.Traversable (traverse)
import Data.Bifunctor (lmap)
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map(..))
import Data.Map as Map
import Data.Tuple (Tuple(..))
import Data.Either (Either(..), either)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Data.Foldable (foldl, for_, intercalate)
import Text.Wrap (dedent)
import Control.Monad.Aff (launchAff)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)

import Test.Assert (assert)
import Test.Spec (Spec(), describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Data.String (fromCharArray)

import Test.Support (vliftEff, runEitherEff, prettyPrintMap)
import Test.Support.Usage  as U
import Test.Support.Docopt as D
import Test.Support.Desc   as Desc

import Docopt as Docopt
import Language.Docopt (runDocopt)
import Language.Docopt.Value as D
import Language.Docopt.Value as Value

import Data.List (List(..), many, some, (:), toList, concat, singleton, length
                , fromList)
import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Parser.Base
import Node.FS (FS)
import Node.Encoding (Encoding(..))
import Node.FS.Sync as FS
import Data.Identity
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Plus (empty)
import Data.Array as A
import Data.Int as Int

newtype Test = Test {
  doc   :: String
, kases :: Array Kase
}

newtype Kase = Kase {
  out     :: Either String (List (Tuple String D.Value))
, options :: Docopt.Options
}

parseUniversalDocoptTests :: forall eff
  . Eff (fs :: FS, err :: EXCEPTION | eff) (List Test)
parseUniversalDocoptTests = do
  f <- FS.readTextFile UTF8 "testcases.docopt"
  runEitherEff $ P.runParser f do
    many kase <* P.eof

  where
    comment = P.char '#' *> P.manyTill P.anyChar (P.char '\n')
    skipComments = void $ many comment

    kase = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      u  <- usage
      as <- A.many application
      return $ Test {
        doc: u
      , kases: as
      }

    application = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      optionsFirst <- (P.choice $ P.try <$> [
        P.string "$ prog"    *> return false
      , P.string "$ partial" *> return true
      ]) P.<?> "\"$ prog\" or \"$ partial\""
      P.skipSpaces
      input <- flip P.sepBy (P.char ' ') do
        many (P.char ' ')
        fromCharArray <$> do
          -- Note: Terminate on '{'. This is hacky and pragmatic,
          -- but it doesn't have to be any more than that...
          A.some $ P.noneOf [ ' ', '{', '\n', '"' ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      output <- P.choice $ P.try <$>
        [ Right <$> do
            P.between (many space *> P.char '{' *> many space)
                      (many space *> P.char '}' *> many space) do
              flip P.sepBy (P.char ',') do
                P.skipSpaces
                key <- P.between (P.char '"') (P.char '"') do
                        fromCharArray <$> do
                          A.many $ P.noneOf [ '"' ]
                P.skipSpaces *> P.char ':' <* P.skipSpaces
                Tuple key <$> value
        , P.string "\"user-error\""
            *> many (P.char ' ')
            *> P.optional comment
            *> return (Left "user-error")
        ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      return $ Kase { out: output
                    , options: {
                        argv:         return $ fromList input
                      , optionsFirst: optionsFirst
                      , env:          Nothing
                      , dontExit:     true
                      }
                    }

      where
        value = P.choice $ P.try <$> [
          D.BoolValue <$> do
            P.choice $ P.try <$> [
              P.string "false" *> return false
            , P.string "true"  *> return true
            ]
        , D.StringValue <$> do
            fromCharArray <$> do
              P.between (P.char '"') (P.char '"') (A.many $ P.noneOf ['"'])
        , D.ArrayValue <<< fromList <$> do
            P.between (P.char '[') (P.char ']') do
              P.skipSpaces
              flip P.sepBy (P.skipSpaces *> P.char ',' *> P.skipSpaces) do
                value
        , do
            si <- P.option 1 (P.char '-' *> return (-1))
            xs <- fromCharArray <$> A.some digit
            P.choice [
              D.FloatValue <<< ((Int.toNumber si) *) <<< readFloat <$> do
                xss <- do
                  P.char '.'
                  fromCharArray <$> A.some digit
                return $ xs ++ "." ++ xss
            , return $ D.IntValue $ si * (fromJust $ Int.fromString xs)
            ]
        ]

    usage = do
      P.string "r\"\"\""
      fromCharArray <<< fromList <$> do
        P.manyTill P.anyChar $ P.string "\"\"\"\n"

-- Somehow, purescript needs this:
_liftEff :: forall e a. Eff e a -> Aff e a
_liftEff = liftEff

type CompatEff e = (fs :: FS, err :: EXCEPTION | e)

genCompatSpec :: forall e. Aff (CompatEff e) (Unit -> Spec (CompatEff e) Unit)
genCompatSpec = do
  tests <- _liftEff parseUniversalDocoptTests
  return $ \_ -> describe "Docopt compatibility" do
    for_ tests \(Test { doc, kases }) -> do
      describe (doc ++ "\n") do
        for_ kases \(Kase { options, out }) -> do
          let argv = fromJust options.argv
          describe (intercalate " " argv) do
            it ("\n" ++ prettyPrintOut out) do

              -- XXX: Manually break the execution context in order to avoid to
              --      avoid stack overflows by executing a large amount of Aff
              --      actions that run purely synchronous. Ideally, we would run
              --      the `Aff` action using it's `MonadRec` instance.
              -- Refer: https://github.com/owickstrom/purescript-spec/issues/24

              later (return unit)

              let result = runDocopt (dedent doc)
                                     StrMap.empty
                                     argv
                                     options.optionsFirst
              vliftEff $ case result of
                Left e ->
                  either
                    (const $ pure unit)
                    (const $ throwException $ error $ e)
                    out
                Right output -> do
                  either
                    (\_ -> do
                      throwException $ error $
                        "Unexpected output: \n"
                          ++ prettyPrintOut (pure $ StrMap.toList output)
                    )
                    (\expected ->
                      let actual = StrMap.toList output
                       in if (StrMap.fromFoldable expected /= output)
                        then throwException $ error $
                          "Unexpected output:\n"
                            ++ prettyPrintOut (pure actual)
                        else return unit)
                    out

  where
    prettyPrintOut :: Either String (List (Tuple String D.Value)) -> String
    prettyPrintOut (Left err) = "fail with " ++ show err
    prettyPrintOut (Right xs)
      = intercalate "\n" $ xs <#> \(Tuple k v) -> k ++ " => " ++ show v

module Test.Spec.CompatSpec (genCompatSpec) where

import Prelude
import Debug.Trace
import Global (readFloat, readInt)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Aff (Aff(), liftEff')
import Control.Monad.Trans (lift)
import Data.List (List(..), toList, concat, last, init)
import Text.Parsing.Parser as P
import Data.Traversable (traverse)
import Data.Bifunctor (lmap)
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Map (Map(..))
import Data.Map as Map
import Data.Tuple (Tuple(..))
import Data.Either (Either(..), either)
import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
import Data.Foldable (foldl, for_, intercalate)
import Text.Wrap (dedent)
import Control.Monad.Aff (launchAff)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)

import Test.Assert (assert)
import Test.Spec (Spec(), describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Data.String (fromCharArray)

import Test.Support (vliftEff, runEitherEff, prettyPrintMap)
import Test.Support.Usage  as U
import Test.Support.Docopt as D
import Test.Support.Desc   as Desc

import Docopt as Docopt
import Language.Docopt (runDocopt)
import Language.Docopt.Value as D
import Language.Docopt.Value as Value

import Data.List (List(..), many, some, (:), toList, concat, singleton, length
                , fromList)
import Text.Parsing.Parser             as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Pos         as P
import Text.Parsing.Parser.String      as P

import Language.Docopt.Parser.Base
import Node.FS (FS)
import Node.Encoding (Encoding(..))
import Node.FS.Sync as FS
import Data.Identity
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Control.Plus (empty)
import Data.Array as A
import Data.Int as Int

newtype Test = Test {
  doc   :: String
, kases :: Array Kase
}

newtype Kase = Kase {
  out     :: Either String (List (Tuple String D.Value))
, options :: Docopt.Options
}

parseUniversalDocoptTests :: forall eff
  . Eff (fs :: FS, err :: EXCEPTION | eff) (List Test)
parseUniversalDocoptTests = do
  f <- FS.readTextFile UTF8 "testcases.docopt"
  runEitherEff $ P.runParser f do
    many kase <* P.eof

  where
    comment = P.char '#' *> P.manyTill P.anyChar (P.char '\n')
    skipComments = void $ many comment

    kase = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      u  <- usage
      as <- A.many application
      return $ Test {
        doc: u
      , kases: as
      }

    application = do
      P.skipSpaces *> skipComments *>  P.skipSpaces
      optionsFirst <- (P.choice $ P.try <$> [
        P.string "$ prog"    *> return false
      , P.string "$ partial" *> return true
      ]) P.<?> "\"$ prog\" or \"$ partial\""
      P.skipSpaces
      input <- flip P.sepBy (P.char ' ') do
        many (P.char ' ')
        fromCharArray <$> do
          -- Note: Terminate on '{'. This is hacky and pragmatic,
          -- but it doesn't have to be any more than that...
          A.some $ P.noneOf [ ' ', '{', '\n', '"' ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      output <- P.choice $ P.try <$>
        [ Right <$> do
            P.between (many space *> P.char '{' *> many space)
                      (many space *> P.char '}' *> many space) do
              flip P.sepBy (P.char ',') do
                P.skipSpaces
                key <- P.between (P.char '"') (P.char '"') do
                        fromCharArray <$> do
                          A.many $ P.noneOf [ '"' ]
                P.skipSpaces *> P.char ':' <* P.skipSpaces
                Tuple key <$> value
        , P.string "\"user-error\""
            *> many (P.char ' ')
            *> P.optional comment
            *> return (Left "user-error")
        ]
      P.skipSpaces *> skipComments *>  P.skipSpaces
      return $ Kase { out: output
                    , options: {
                        argv:         return $ fromList input
                      , optionsFirst: optionsFirst
                      , env:          Nothing
                      , dontExit:     true
                      }
                    }

      where
        value = P.choice $ P.try <$> [
          D.BoolValue <$> do
            P.choice $ P.try <$> [
              P.string "false" *> return false
            , P.string "true"  *> return true
            ]
        , D.StringValue <$> do
            fromCharArray <$> do
              P.between (P.char '"') (P.char '"') (A.many $ P.noneOf ['"'])
        , D.ArrayValue <<< fromList <$> do
            P.between (P.char '[') (P.char ']') do
              P.skipSpaces
              flip P.sepBy (P.skipSpaces *> P.char ',' *> P.skipSpaces) do
                value
        , do
            si <- P.option 1 (P.char '-' *> return (-1))
            xs <- fromCharArray <$> A.some digit
            P.choice [
              D.FloatValue <<< ((Int.toNumber si) *) <<< readFloat <$> do
                xss <- do
                  P.char '.'
                  fromCharArray <$> A.some digit
                return $ xs ++ "." ++ xss
            , return $ D.IntValue $ si * (fromJust $ Int.fromString xs)
            ]
        ]

    usage = do
      P.string "r\"\"\""
      fromCharArray <<< fromList <$> do
        P.manyTill P.anyChar $ P.string "\"\"\"\n"

-- Somehow, purescript needs this:
_liftEff :: forall e a. Eff e a -> Aff e a
_liftEff = liftEff

type CompatEff e = (fs :: FS, err :: EXCEPTION | e)

genCompatSpec :: forall e. Aff (CompatEff e) (Unit -> Spec (CompatEff e) Unit)
genCompatSpec = do
  tests <- _liftEff parseUniversalDocoptTests
  return $ \_ -> describe "Docopt compatibility" do
    for_ tests \(Test { doc, kases }) -> do
      describe (doc ++ "\n") do
        for_ kases \(Kase { options, out }) -> do
          let argv = fromJust options.argv
          describe (intercalate " " argv) do
            it ("\n" ++ prettyPrintOut out) do
              let result = runDocopt (dedent doc)
                                     StrMap.empty
                                     argv
                                     options.optionsFirst
              vliftEff $ case result of
                Left e ->
                  either
                    (const $ pure unit)
                    (const $ throwException $ error $ e)
                    out
                Right output -> do
                  either
                    (\_ -> do
                      throwException $ error $
                        "Unexpected output: \n"
                          ++ prettyPrintOut (pure $ StrMap.toList output)
                    )
                    (\expected ->
                      let actual = StrMap.toList output
                       in if (StrMap.fromFoldable expected /= output)
                        then throwException $ error $
                          "Unexpected output:\n"
                            ++ prettyPrintOut (pure actual)
                        else return unit)
                    out

  where
    prettyPrintOut :: Either String (List (Tuple String D.Value)) -> String
    prettyPrintOut (Left err) = "fail with " ++ show err
    prettyPrintOut (Right xs)
      = intercalate "\n" $ xs <#> \(Tuple k v) -> k ++ " => " ++ show v