Codec.purs

module Sexp.Codec
  ( SexpDecodeError(..)
  , sexp
  , boolean
  , number
  , int
  , string
  , array
  ) where

import Prelude

import Data.Array as Array
import Data.Codec (BasicCodec, basicCodec, decode, encode)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (traverse)
import Sexp (Atom(..), Sexp(..))

data SexpDecodeError
  = TypeMismatch String
  | SexpDecodeError String

type SexpCodec a = BasicCodec (Either SexpDecodeError) Sexp a

sexp :: SexpCodec Sexp
sexp = basicCodec pure identity

boolean :: SexpCodec Boolean
boolean = sexpPrimCodec "Boolean"
    do case _ of
         Atom (ASymbol "true") -> Just true
         Atom (ASymbol "true") -> Just false
         _ -> Nothing
    do Atom <<< ASymbol <<< show

number :: SexpCodec Number
number = sexpPrimCodec "Number"
    do case _ of
         Atom (ANumber n) -> Just n
         _ -> Nothing
    do Atom <<< ANumber

int :: SexpCodec Int
int = sexpPrimCodec "Int"
    do case _ of
         Atom (AInt n) -> Just n
         _ -> Nothing
    do Atom <<< AInt

string :: SexpCodec String
string = sexpPrimCodec "String"
    do case _ of
         Atom (AString n) -> Just n
         _ -> Nothing
    do Atom <<< AString

array :: forall a. SexpCodec a -> SexpCodec (Array a)
array c = basicCodec dec enc
  where
    enc as = Complex (Array.cons (Atom (ASymbol "array")) (map (encode c) as))
    dec = case _ of
      Complex xs
        | Just { head, tail } <- Array.uncons xs
        , Atom (ASymbol "array") <- head ->
          traverse (decode c) tail
      _ ->
        Left (TypeMismatch "Array")

sexpPrimCodec :: forall a. String -> (Sexp -> Maybe a) -> (a -> Sexp) -> SexpCodec a
sexpPrimCodec ty f = basicCodec (maybe (Left (TypeMismatch ty)) pure <<< f)

fix :: forall a b m. (BasicCodec m a b -> BasicCodec m a b) -> BasicCodec m a b
fix f =
  basicCodec
    (\x → decode (f (fix f)) x)
    (\x → encode (f (fix f)) x)

packages.dhall

{-
Welcome to your new Dhall package-set!

Below are instructions for how to edit this file for most use
cases, so that you don't need to know Dhall to use it.

## Warning: Don't Move This Top-Level Comment!

Due to how `dhall format` currently works, this comment's
instructions cannot appear near corresponding sections below
because `dhall format` will delete the comment. However,
it will not delete a top-level comment like this one.

## Use Cases

Most will want to do one or both of these options:
1. Override/Patch a package's dependency
2. Add a package not already in the default package set

This file will continue to work whether you use one or both options.
Instructions for each option are explained below.

### Overriding/Patching a package

Purpose:
- Change a package's dependency to a newer/older release than the
    default package set's release
- Use your own modified version of some dependency that may
    include new API, changed API, removed API by
    using your custom git repo of the library rather than
    the package set's repo

Syntax:
Replace the overrides' "{=}" (an empty record) with the following idea
The "//" or "⫽" means "merge these two records and
  when they have the same value, use the one on the right:"
-------------------------------
let overrides =
  { packageName =
      upstream.packageName // { updateEntity1 = "new value", updateEntity2 = "new value" }
  , packageName =
      upstream.packageName // { version = "v4.0.0" }
  , packageName =
      upstream.packageName // { repo = "https://www.example.com/path/to/new/repo.git" }
  }
-------------------------------

Example:
-------------------------------
let overrides =
  { halogen =
      upstream.halogen // { version = "master" }
  , halogen-vdom =
      upstream.halogen-vdom // { version = "v4.0.0" }
  }
-------------------------------

### Additions

Purpose:
- Add packages that aren't already included in the default package set

Syntax:
Replace the additions' "{=}" (an empty record) with the following idea:
-------------------------------
let additions =
  { package-name =
       { dependencies =
           [ "dependency1"
           , "dependency2"
           ]
       , repo =
           "https://example.com/path/to/git/repo.git"
       , version =
           "tag ('v4.0.0') or branch ('master')"
       }
  , package-name =
       { dependencies =
           [ "dependency1"
           , "dependency2"
           ]
       , repo =
           "https://example.com/path/to/git/repo.git"
       , version =
           "tag ('v4.0.0') or branch ('master')"
       }
  , etc.
  }
-------------------------------

Example:
-------------------------------
let additions =
  { benchotron =
      { dependencies =
          [ "arrays"
          , "exists"
          , "profunctor"
          , "strings"
          , "quickcheck"
          , "lcg"
          , "transformers"
          , "foldable-traversable"
          , "exceptions"
          , "node-fs"
          , "node-buffer"
          , "node-readline"
          , "datetime"
          , "now"
          ]
      , repo =
          "https://github.com/hdgarrood/purescript-benchotron.git"
      , version =
          "v7.0.0"
      }
  }
-------------------------------
-}


let upstream =
      https://github.com/purescript/package-sets/releases/download/psc-0.13.6-20200226/packages.dhall sha256:3a52562e05b31a7b51d12d5b228ccbe567c527781a88e9028ab42374ab55c0f1

let overrides = {=}

let additions = {
    codec = {
        dependencies = [ "transformers", "profunctor" ]
        , repo = "https://github.com/garyb/purescript-codec.git"
        , version = "v3.0.0"
    }
}

in  upstream // overrides // additions

Sexp.purs

module Sexp
  ( Sexp(..)
  , Atom(..)
  , class ToSexp, toSexp
  , class GenericToSexp, genericToSexp, genericToSexp'
  ) where

import Prelude

import Data.Array as Array
import Data.Generic.Rep (class Generic, Argument(..), Constructor(..), NoArguments, NoConstructors, Product(..), Sum(..), from)
import Data.Maybe (Maybe(..))
import Data.String as String
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Effect (Effect)
import Effect.Console (log)
import Prim.RowList as RL
import Record.Unsafe (unsafeGet)
import Type.Data.RowList (RLProxy(..))

data Atom
  = AString String
  | AInt Int
  | ANumber Number
  | ASymbol String

data Sexp = Atom Atom | Complex (Array Sexp)

render :: Sexp -> String
render = case _ of
  Atom a ->
    renderAtom a
  Complex as ->
    "(" <> String.joinWith " " (map render as) <> ")"

renderAtom :: Atom -> String
renderAtom = case _ of
  AString s -> show s
  AInt i -> show i
  ANumber n -> show n
  ASymbol s -> s

class ToSexp a where
  toSexp :: a -> Sexp

instance sexpInt :: ToSexp Int where
  toSexp i = Atom (AInt i)

instance sexpNumber :: ToSexp Number where
  toSexp s = Atom (ANumber s)

instance sexpString :: ToSexp String where
  toSexp s = Atom (AString s)

instance sexpBoolean :: ToSexp Boolean where
  toSexp b = Atom (ASymbol (show b))

instance sexpArray :: ToSexp a => ToSexp (Array a) where
  toSexp xs = Complex ([Atom (ASymbol "array")] <> map toSexp xs)

instance sexpRecord :: (RL.RowToList rs ls, ToSexpRecordFields ls rs) => ToSexp (Record rs) where
  toSexp record = Complex (Array.cons (Atom (ASymbol "record")) (toSexpRecordFields (RLProxy :: RLProxy ls) record))

-- | A class for records where all fields have `ToSexp` instances, used to
-- | implement the `ToSexp` instance for records.
class ToSexpRecordFields rowlist row where
  toSexpRecordFields :: RLProxy rowlist -> Record row -> Array Sexp

instance toSexpRecordFieldsNil :: ToSexpRecordFields RL.Nil row where
  toSexpRecordFields _ _ = []

instance toSexpRecordFieldsCons
    :: ( IsSymbol key
       , ToSexpRecordFields rowlistTail row
       , ToSexp focus
       )
    => ToSexpRecordFields (RL.Cons key focus rowlistTail) row where
  toSexpRecordFields _ record
    = Array.cons (Complex [ toSexp key, toSexp focus ]) tail
    where
      key = reflectSymbol (SProxy :: SProxy key)
      focus = unsafeGet key record :: focus
      tail = toSexpRecordFields (RLProxy :: RLProxy rowlistTail) record

instance sexpMaybe :: ToSexp a => ToSexp (Maybe a) where
  toSexp x = genericToSexp x

class GenericToSexp a where
  genericToSexp' :: a -> Sexp

class GenericToSexpArgs a where
  genericToSexpArgs :: a -> Array Sexp

instance genericToSexpNoConstructors :: GenericToSexp NoConstructors where
  genericToSexp' a = genericToSexp' a

instance genericToSexpArgsNoArguments :: GenericToSexpArgs NoArguments where
  genericToSexpArgs _ = []

instance genericToSexpSum :: (GenericToSexp a, GenericToSexp b) => GenericToSexp (Sum a b) where
  genericToSexp' (Inl a) = genericToSexp' a
  genericToSexp' (Inr b) = genericToSexp' b

instance genericToSexpArgsProduct
    :: (GenericToSexpArgs a, GenericToSexpArgs b)
    => GenericToSexpArgs (Product a b) where
  genericToSexpArgs (Product a b) = genericToSexpArgs a <> genericToSexpArgs b

instance genericToSexpConstructor
  :: (GenericToSexpArgs a, IsSymbol name)
  => GenericToSexp (Constructor name a) where
  genericToSexp' (Constructor a) =
      case genericToSexpArgs a of
        [] -> Atom ctor
        args -> Complex (Array.cons (Atom ctor) args)
    where
      ctor :: Atom
      ctor = ASymbol (reflectSymbol (SProxy :: SProxy name))

instance genericToSexpArgsArgument :: ToSexp a => GenericToSexpArgs (Argument a) where
  genericToSexpArgs (Argument a) = [toSexp a]

-- | A `Generic` implementation of the `toSexp` member from the `ToSexp` type class.
genericToSexp :: forall a rep. Generic a rep => GenericToSexp rep => a -> Sexp
genericToSexp x = genericToSexp' (from x)

logSexp :: forall a. ToSexp a => a -> Effect Unit
logSexp = log <<< render <<< toSexp

main :: Effect Unit
main = do
  log (render (Complex (map Atom [ ASymbol "Just", AInt 10 ])))
  logSexp true
  logSexp "hello"
  logSexp 10
  logSexp ["hello", "thing"]
  logSexp { a: 10, hello: ["world", "thing"] }
  logSexp [Just 10, Nothing]