Skip to content
Permalink
Browse files

Pretty printer for Marlowe in purescript

  • Loading branch information...
David Smith
David Smith committed Mar 14, 2019
1 parent 23bae57 commit 5db3d0436aeb52be9b6c9bf88abd251c47dcf391
@@ -11,6 +11,8 @@ import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Ord (genericCompare)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over2, unwrap)
import Marlowe.Pretty (class Pretty)
import Text.PrettyPrint.Leijen (text)

newtype BigInteger
= BigInteger BigInt
@@ -28,6 +30,9 @@ instance ordBigInteger :: Ord BigInteger where
instance showBigInteger :: Show BigInteger where
show = toString <<< unwrap

instance genericPrettyBigInteger :: Pretty BigInteger where
pretty = text <<< show

fromInt :: Int -> BigInteger
fromInt = BigInteger <<< BigInt.fromInt

@@ -1,158 +1,61 @@
module MainFrame (mainFrame) where

import API (SourceCode(SourceCode))
import Ace.Halogen.Component
( AceEffects
, AceMessage
( TextChanged
)
, AceQuery
( GetEditor
)
)
import Ace.EditSession as Session
import Ace.Editor as Editor
import Ace.Halogen.Component (AceEffects, AceMessage(TextChanged), AceQuery(GetEditor))
import Ace.Types (ACE, Editor, Annotation)
import AjaxUtils (runAjaxTo)
import Analytics (Event, defaultEvent, trackEvent, ANALYTICS)
import Bootstrap
( active
, btn
, btnGroup
, btnSmall
, container
, container_
, hidden
, navItem_
, navLink
, navTabs_
, pullRight
)
import Bootstrap (active, btn, btnGroup, btnSmall, container, container_, hidden, navItem_, navLink, navTabs_, pullRight)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Reader.Class (class MonadAsk)
import Data.Array as Array
import Data.Array (catMaybes)
import Data.Array as Array
import Data.BigInteger (BigInteger, fromInt)
import Data.Either (Either(..))
import Data.Foldable (foldrDefault)
import Data.Lens (assign, modifying, over, preview, set, use)
import Data.List (List(..))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing))
import Data.Ord (min, max, (>=))
import Data.Set (Set)
import Data.Set as Set
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.Tuple (Tuple(Tuple))
import Data.Tuple.Nested ((/\))
import Editor (editorPane)
import FileEvents (FILE, preventDefault, readFileFromDragEvent)
import Gist (gistId)
import Gists (mkNewGist)
import Halogen (Component, action)
import Halogen as H
import Halogen.Component (ParentHTML)
import Halogen.ECharts (EChartsEffects)
import Halogen.HTML (ClassName(ClassName), HTML, a, div, div_, h1, text)
import Halogen.HTML.Events (onClick)
import Halogen.HTML.Properties (class_, classes, href)
import Halogen.Query (HalogenM)
import Language.Haskell.Interpreter
( CompilationError
( CompilationError
, RawError
)
)
import Language.Haskell.Interpreter (CompilationError(CompilationError, RawError))
import LocalStorage (LOCALSTORAGE)
import Meadow
( SPParams_
, getOauthStatus
, patchGistsByGistId
, postGists
, postContractHaskell
)
import LocalStorage as LocalStorage
import Marlowe.Parser as Parser
import Marlowe.Types (BlockNumber, Choice, Contract(..), IdChoice(..), Person, IdOracle)
import Meadow (SPParams_, getOauthStatus, patchGistsByGistId, postGists, postContractHaskell)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(Success, NotAsked), _Success)
import Data.Ord (min, max, (>=))
import Prelude
( type (~>)
, Unit
, Void
, bind
, const
, discard
, id
, pure
, show
, unit
, void
, ($)
, (+)
, (-)
, (<$>)
, (<<<)
, (<>)
, (==)
)
import Semantics
( BlockNumber
, Choice
, Contract(..)
, IdChoice(..)
, IdInput(..)
, IdOracle
, ErrorResult(..)
, MApplicationResult(..)
, Person
, State(..)
, applyTransaction
, collectNeededInputsFromContract
, emptyState
, peopleFromStateAndContract
, readContract
, reduce
, scoutPrimitives
)
import Prelude (type (~>), Unit, Void, bind, const, discard, id, pure, show, unit, void, ($), (+), (-), (<$>), (<<<), (<>), (==))
import Semantics (ErrorResult(..), IdInput(..), MApplicationResult(..), State(..), applyTransaction, collectNeededInputsFromContract, emptyState, peopleFromStateAndContract, readContract, reduce, scoutPrimitives)
import Servant.PureScript.Settings (SPSettings_)
import Simulation (simulationPane)
import StaticData (bufferLocalStorageKey, marloweBufferLocalStorageKey)
import Text.Parsing.Simple (parse)
import Types
( ChildQuery
, ChildSlot
, EditorSlot(..)
, FrontendState
, InputData
, MarloweEditorSlot(..)
, MarloweError(..)
, MarloweState
, OracleEntry
, Query(..)
, TransactionData
, View(..)
, _authStatus
, _blockNum
, _choiceData
, _contract
, _createGistResult
, _marloweCompileResult
, _marloweState
, _input
, _inputs
, _oracleData
, _runResult
, _signatures
, _transaction
, _view
, cpEditor
, cpMarloweEditor
)

import Ace.EditSession as Session
import Ace.Editor as Editor
import Data.String as String
import Halogen as H
import LocalStorage as LocalStorage
import Marlowe.Parser as Parser
import StaticData as StaticData
import Text.Parsing.Simple (parse)
import Types (ChildQuery, ChildSlot, EditorSlot(..), FrontendState, InputData, MarloweEditorSlot(..), MarloweError(..), MarloweState, OracleEntry, Query(..), TransactionData, View(..), _authStatus, _blockNum, _choiceData, _contract, _createGistResult, _marloweCompileResult, _marloweState, _input, _inputs, _oracleData, _runResult, _signatures, _transaction, _view, cpEditor, cpMarloweEditor)

emptyInputData :: InputData
emptyInputData = { inputs: Map.empty
@@ -8,7 +8,7 @@ import Control.Monad.Rec.Class (class MonadRec)
import Data.BigInteger (BigInteger)
import Data.Newtype (wrap)
import Data.NonEmpty ((:|))
import Semantics (Contract(..), IdChoice, Observation(..), Value(..))
import Marlowe.Types (Contract(..), IdChoice, Observation(..), Value(..))

import Control.Monad.Gen as Gen
import Data.BigInteger as BigInteger
@@ -8,13 +8,13 @@ import Data.BigInteger as BigInteger
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Newtype (wrap)
import Semantics (BlockNumber, Choice, Contract(..), IdAction, IdChoice, IdCommit, IdOracle, LetLabel, Observation(..), Person, Timeout, Value(..))
import Text.Parsing.Simple (Parser, char, fail, fix, integral, parens, some, space, string)
import Marlowe.Types (BlockNumber, Choice, Contract(..), IdAction, IdChoice, IdCommit, IdOracle, LetLabel, Observation(..), Person, Timeout, Value(..))
import Text.Parsing.Simple (Parser, char, fail, fix, integral, parens, some, space, string, whitespace)

-- All arguments are space separated so we add **> to reduce boilerplate

spaces :: Parser String (List Char)
spaces = some space
spaces = some whitespace

appRSpaces :: forall a b. Parser String a -> Parser String b -> Parser String b
appRSpaces p q = p *> spaces *> q
@@ -0,0 +1,98 @@
module Marlowe.Pretty where

import Prelude

import Data.Array (uncons)
import Data.Foldable (foldl)
import Data.Generic.Rep
( class Generic
, Argument(..)
, Constructor(..)
, NoArguments
, NoConstructors
, Product(..)
, Sum(..)
, from
)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.String (Pattern(..), contains, length)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Text.PrettyPrint.Leijen
( Doc
( Empty
)
, appendWithLine
, hang
, parens
, text
, (<+>)
)

class Pretty a where
pretty :: a -> Doc

class GenericPrettyArgs a where
genericPrettyArgs' :: a -> Array Doc

instance genericPrettyNoConstructors :: Pretty NoConstructors where
pretty a = mempty

instance genericPrettyArgsNoArguments :: GenericPrettyArgs NoArguments where
genericPrettyArgs' _ = []

instance genericPrettySum :: (Pretty a, Pretty b) => Pretty (Sum a b) where
pretty (Inl a) = pretty a
pretty (Inr b) = pretty b

instance genericPrettyArgsProduct ::
( GenericPrettyArgs a
, GenericPrettyArgs b
) =>
GenericPrettyArgs (Product a b) where
genericPrettyArgs' (Product a b) = genericPrettyArgs' a <> genericPrettyArgs' b

instance genericPrettyConstructor ::
( GenericPrettyArgs a
, IsSymbol name
) =>
Pretty (Constructor name a) where
pretty (Constructor a) = case genericPrettyArgs' a of
args -> case uncons args of
Just { head: x, tail: [] } -> hang ((length ctor) + 1) (text ctor <+> (parens' x))
Just { head: x, tail: xs } -> hang ((length ctor) + 1) (text ctor <+> (parens' x) `appendWithLine'` (foldl (\a b ->
(parens' (appendWithLine' a b)))) mempty xs)
Nothing -> text ctor
where
ctor ::
String
ctor = reflectSymbol (SProxy :: SProxy name)
parens' ::
Doc ->
Doc
parens' Empty = Empty
parens' d
| contains (Pattern " ") (show d) = parens d
| otherwise = d
appendWithLine' ::
Doc ->
Doc ->
Doc
appendWithLine' Empty d = d
appendWithLine' d Empty = d
appendWithLine' a b = appendWithLine a b

instance genericPrettyArgsArgument ::
( Pretty a
) =>
GenericPrettyArgs (Argument a) where
genericPrettyArgs' (Argument a) = [pretty a]

instance genericPrettyString :: Pretty String where
pretty a = text (show a)

instance genericPrettyInt :: Pretty Int where
pretty a = text (show a)

genericPretty :: forall a rep. Generic a rep => Pretty rep => a -> Doc
genericPretty x = pretty (from x)
Oops, something went wrong.

0 comments on commit 5db3d04

Please sign in to comment.
You can’t perform that action at this time.