{- FOURMOLU_DISABLE -}
-- The MIT License (MIT)

-- Copyright (c) 2016-2024 Objectionary.com

-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.
{- FOURMOLU_ENABLE -}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Language.EO.Phi.Syntax (
  module Language.EO.Phi.Syntax.Abs,
  desugar,
  printTree,
  printTreeDontSugar,

  -- * Conversion to 'Bytes'
  intToBytes,
  int64ToBytes,
  int32ToBytes,
  int16ToBytes,
  floatToBytes,
  boolToBytes,
  stringToBytes,

  -- * Conversion from 'Bytes'
  bytesToInt,
  bytesToInt64,
  bytesToInt32,
  bytesToInt16,
  bytesToFloat,
  bytesToString,
  bytesToBool,

  -- * Wrapping 'Bytes' into 'Object'
  wrapBytesInConstInt,
  wrapBytesInConstInt64,
  wrapBytesInConstInt32,
  wrapBytesInConstInt16,
  wrapBytesInConstFloat,
  wrapBytesInConstString,
  wrapBytesInBytes,
  wrapBytesInInt,
  wrapBytesInFloat,
  wrapBytesAsBool,
  wrapBytesInString,
  wrapTermination,

  -- * Functions over 'Bytes'
  sliceBytes,
  concatBytes,

  -- * Helpers
  chunksOf,
  paddedLeftChunksOf,
  normalizeBytes,
  parseWith,
  errorExpectedDesugaredObject,
  errorExpectedDesugaredBinding,
  errorExpectedDesugaredAttribute,

  -- * Classes
  SugarableFinally (..),

  -- * Pattern synonyms
  pattern AlphaBinding',
  pattern AlphaBinding'',
) where

import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString.Strict
import Data.Char (toUpper)
import Data.Foldable1 (intercalate1)
import Data.Int
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Serialize qualified as Serialize
import Data.String (IsString (fromString))
import Data.Text qualified as T
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import GHC.Float (isDoubleFinite)
import Language.EO.Phi.Preprocess (preprocess)
import Language.EO.Phi.Pretty ()
import Language.EO.Phi.Syntax.Abs
import Language.EO.Phi.Syntax.Lex (Token)
import Language.EO.Phi.Syntax.Par
import Numeric (readHex, showHex)
import Prettyprinter (LayoutOptions (..), PageWidth (..), Pretty (pretty), defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text (renderStrict)
import PyF (fmt)
import Text.Printf (printf)
import Validation (Validation (..))

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> :set -XOverloadedLists

errorExpectedButGot :: (Pretty a, SugarableFinally a) => String -> a -> b
errorExpectedButGot :: forall a b. (Pretty a, SugarableFinally a) => [Char] -> a -> b
errorExpectedButGot [Char]
type' a
x = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([fmt|impossible: expected desugared {type'}, but got:\n|] [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> a -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree a
x)

errorExpectedDesugaredObject :: Object -> a
errorExpectedDesugaredObject :: forall a. Object -> a
errorExpectedDesugaredObject = [Char] -> Object -> a
forall a b. (Pretty a, SugarableFinally a) => [Char] -> a -> b
errorExpectedButGot [Char]
"Object"

errorExpectedDesugaredBinding :: Binding -> a
errorExpectedDesugaredBinding :: forall a. Binding -> a
errorExpectedDesugaredBinding = [Char] -> Binding -> a
forall a b. (Pretty a, SugarableFinally a) => [Char] -> a -> b
errorExpectedButGot [Char]
"Binding"

errorExpectedDesugaredAttribute :: Attribute -> a
errorExpectedDesugaredAttribute :: forall a. Attribute -> a
errorExpectedDesugaredAttribute = [Char] -> Attribute -> a
forall a b. (Pretty a, SugarableFinally a) => [Char] -> a -> b
errorExpectedButGot [Char]
"Attribute"

class DesugarableInitially a where
  desugarInitially :: a -> a
  desugarInitially = a -> a
forall a. a -> a
id

instance DesugarableInitially Object where
  desugarInitially :: Object -> Object
  desugarInitially :: Object -> Object
desugarInitially = \case
    obj :: Object
obj@(ConstString{}) -> Object
obj
    ConstStringRaw (StringRaw [Char]
s) -> [Char] -> Object
ConstString ([Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init ([Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail [Char]
s))
    obj :: Object
obj@(ConstInt{}) -> Object
obj
    ConstIntRaw (IntegerSigned [Char]
x) -> Integer -> Object
ConstInt ([Char] -> Integer
forall a. Read a => [Char] -> a
read [Char]
x)
    obj :: Object
obj@(ConstFloat{}) -> Object
obj
    ConstFloatRaw (DoubleSigned [Char]
x) -> Double -> Object
ConstFloat ([Char] -> Double
forall a. Read a => [Char] -> a
read [Char]
x)
    Formation [Binding]
bindings -> [Binding] -> Object
Formation ([Binding] -> [Binding]
forall a. DesugarableInitially a => a -> a
desugarInitially [Binding]
bindings)
    Application Object
obj [Binding]
bindings -> Object -> [Binding] -> Object
Application (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj) ([Binding] -> [Binding]
forall a. DesugarableInitially a => a -> a
desugarInitially [Binding]
bindings)
    ObjectDispatch Object
obj Attribute
a -> Object -> Attribute -> Object
ObjectDispatch (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj) Attribute
a
    Object
GlobalObject -> Object
GlobalObject
    Object
GlobalObjectPhiOrg -> Object
"Φ.org.eolang"
    Object
ThisObject -> Object
ThisObject
    Object
Termination -> Object
Termination
    MetaSubstThis Object
obj Object
this -> Object -> Object -> Object
MetaSubstThis (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj) (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
this)
    obj :: Object
obj@MetaObject{} -> Object
obj
    MetaContextualize Object
obj1 Object
obj2 -> Object -> Object -> Object
MetaContextualize (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj1) (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj2)
    MetaTailContext Object
obj TailMetaId
metaId -> Object -> TailMetaId -> Object
MetaTailContext (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj) TailMetaId
metaId
    MetaFunction MetaFunctionName
name Object
obj -> MetaFunctionName -> Object -> Object
MetaFunction MetaFunctionName
name (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj)

instance DesugarableInitially [Binding] where
  desugarInitially :: [Binding] -> [Binding]
  desugarInitially :: [Binding] -> [Binding]
desugarInitially = (Int -> Binding -> Binding) -> [Int] -> [Binding] -> [Binding]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Binding -> Binding
go [Int
0 ..]
   where
    go :: Int -> Binding -> Binding
    go :: Int -> Binding -> Binding
go Int
idx = \case
      AlphaBinding'' LabelId
l [Attribute]
ls (Formation [Binding]
bindings) ->
        let bindingsDesugared :: [Binding]
bindingsDesugared = [Binding] -> [Binding]
forall a. DesugarableInitially a => a -> a
desugarInitially [Binding]
bindings
         in Attribute -> Object -> Binding
AlphaBinding' (LabelId -> Attribute
Label LabelId
l) ([Binding] -> Object
Formation ((Attribute -> Binding
EmptyBinding (Attribute -> Binding) -> [Attribute] -> [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attribute]
ls) [Binding] -> [Binding] -> [Binding]
forall a. Semigroup a => a -> a -> a
<> [Binding]
bindingsDesugared))
      AlphaBinding AttributeSugar
a Object
obj -> AttributeSugar -> Object -> Binding
AlphaBinding AttributeSugar
a (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj)
      AlphaBindingSugar Object
obj -> Attribute -> Object -> Binding
AlphaBinding' (AlphaIndex -> Attribute
Alpha ([Char] -> AlphaIndex
AlphaIndex [fmt|α{idx}|])) (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj)
      Binding
binding -> Binding
binding

instance DesugarableInitially Program where
  desugarInitially :: Program -> Program
  desugarInitially :: Program -> Program
desugarInitially (Program [Binding]
bindings) = [Binding] -> Program
Program ([Binding] -> [Binding]
forall a. DesugarableInitially a => a -> a
desugarInitially [Binding]
bindings)

instance DesugarableInitially Binding where
  desugarInitially :: Binding -> Binding
desugarInitially = \case
    obj :: Binding
obj@AlphaBindingSugar{} -> Binding -> Binding
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
obj
    AlphaBinding AttributeSugar
a Object
obj -> AttributeSugar -> Object -> Binding
AlphaBinding AttributeSugar
a (Object -> Object
forall a. DesugarableInitially a => a -> a
desugarInitially Object
obj)
    Binding
obj -> Binding
obj

instance DesugarableInitially AttributeSugar
instance DesugarableInitially Attribute
instance DesugarableInitially RuleAttribute
instance DesugarableInitially PeeledObject
instance DesugarableInitially ObjectHead
instance DesugarableInitially MetaId

class CheckableSyntaxInitially a where
  checkSyntax :: a -> Validation (NonEmpty String) a
  checkSyntax = a -> Validation (NonEmpty [Char]) a
forall a. a -> Validation (NonEmpty [Char]) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance CheckableSyntaxInitially Program where
  checkSyntax :: Program -> Validation (NonEmpty [Char]) Program
checkSyntax (Program [Binding]
bindings) = [Binding] -> Program
Program ([Binding] -> Program)
-> Validation (NonEmpty [Char]) [Binding]
-> Validation (NonEmpty [Char]) Program
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding -> Validation (NonEmpty [Char]) Binding)
-> [Binding] -> Validation (NonEmpty [Char]) [Binding]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Binding -> Validation (NonEmpty [Char]) Binding
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax [Binding]
bindings

instance CheckableSyntaxInitially Binding where
  checkSyntax :: Binding -> Validation (NonEmpty [Char]) Binding
checkSyntax = \case
    AlphaBinding' Attribute
a Object
obj -> Attribute -> Object -> Binding
AlphaBinding' Attribute
a (Object -> Binding)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj
    AlphaBinding'' LabelId
a [Attribute]
as Object
obj ->
      case ([Attribute]
as, Object
obj) of
        -- inline-voids-on-application
        -- {⟦ k() ↦ ⟦ ⟧() ⟧}
        ([], o :: Object
o@(Application (Formation []) [])) -> NonEmpty [Char] -> Validation (NonEmpty [Char]) Binding
forall e a. e -> Validation e a
Failure (Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
o [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [])
        -- inline-voids-on-dispatch
        -- {⟦ k() ↦ ⟦ ⟧.x ⟧}
        ([], o :: Object
o@(ObjectDispatch (Formation []) Attribute
_)) -> NonEmpty [Char] -> Validation (NonEmpty [Char]) Binding
forall e a. e -> Validation e a
Failure (Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
o [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [])
        ([Attribute], Object)
_ -> LabelId -> [Attribute] -> Object -> Binding
AlphaBinding'' LabelId
a [Attribute]
as (Object -> Binding)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj
    AlphaBindingSugar Object
obj -> Object -> Binding
AlphaBindingSugar (Object -> Binding)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj
    Binding
b -> Binding -> Validation (NonEmpty [Char]) Binding
forall a. a -> Validation (NonEmpty [Char]) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
b

instance CheckableSyntaxInitially Object where
  checkSyntax :: Object -> Validation (NonEmpty [Char]) Object
checkSyntax = \case
    -- application-to-formation
    -- {⟦ k ↦ ⟦ ⟧ (t ↦ ξ.t) ⟧}
    o :: Object
o@(Application (Formation []) [Binding
_]) -> NonEmpty [Char] -> Validation (NonEmpty [Char]) Object
forall e a. e -> Validation e a
Failure (Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
o [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [])
    o :: Object
o@(Application Object
_ [Binding]
xs)
      | let
          isBadBinding :: Binding -> Bool
isBadBinding = \case
            -- delta-in-application
            -- {⟦ k ↦ ξ.t (Δ ⤍ 42-) ⟧}
            DeltaBinding{} -> Bool
True
            DeltaEmptyBinding{} -> Bool
True
            -- lambda-in-application
            -- {⟦ k ↦ ξ.t (λ ⤍ Fn) ⟧}
            LambdaBinding{} -> Bool
True
            -- void-as-value
            -- {⟦ k ↦ ξ.t (t ↦ ∅) ⟧}
            EmptyBinding{} -> Bool
True
            Binding
_ -> Bool
False
         in
          [Binding
d | Binding
d <- [Binding]
xs, Binding -> Bool
isBadBinding Binding
d] [Binding] -> [Binding] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] ->
          NonEmpty [Char] -> Validation (NonEmpty [Char]) Object
forall e a. e -> Validation e a
Failure (Object -> [Char]
forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree Object
o [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [])
    ObjectDispatch Object
obj Attribute
x -> Object -> Attribute -> Object
ObjectDispatch (Object -> Attribute -> Object)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) (Attribute -> Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj Validation (NonEmpty [Char]) (Attribute -> Object)
-> Validation (NonEmpty [Char]) Attribute
-> Validation (NonEmpty [Char]) Object
forall a b.
Validation (NonEmpty [Char]) (a -> b)
-> Validation (NonEmpty [Char]) a -> Validation (NonEmpty [Char]) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Attribute -> Validation (NonEmpty [Char]) Attribute
forall a. a -> Validation (NonEmpty [Char]) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attribute
x
    MetaSubstThis Object
obj1 Object
obj2 -> Object -> Object -> Object
MetaSubstThis (Object -> Object -> Object)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) (Object -> Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj1 Validation (NonEmpty [Char]) (Object -> Object)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) Object
forall a b.
Validation (NonEmpty [Char]) (a -> b)
-> Validation (NonEmpty [Char]) a -> Validation (NonEmpty [Char]) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj2
    MetaContextualize Object
obj1 Object
obj2 -> Object -> Object -> Object
MetaContextualize (Object -> Object -> Object)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) (Object -> Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj1 Validation (NonEmpty [Char]) (Object -> Object)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) Object
forall a b.
Validation (NonEmpty [Char]) (a -> b)
-> Validation (NonEmpty [Char]) a -> Validation (NonEmpty [Char]) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj2
    MetaTailContext Object
obj TailMetaId
x -> Object -> TailMetaId -> Object
MetaTailContext (Object -> TailMetaId -> Object)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) (TailMetaId -> Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj Validation (NonEmpty [Char]) (TailMetaId -> Object)
-> Validation (NonEmpty [Char]) TailMetaId
-> Validation (NonEmpty [Char]) Object
forall a b.
Validation (NonEmpty [Char]) (a -> b)
-> Validation (NonEmpty [Char]) a -> Validation (NonEmpty [Char]) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TailMetaId -> Validation (NonEmpty [Char]) TailMetaId
forall a. a -> Validation (NonEmpty [Char]) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TailMetaId
x
    MetaFunction MetaFunctionName
n Object
obj -> MetaFunctionName -> Object -> Object
MetaFunction MetaFunctionName
n (Object -> Object)
-> Validation (NonEmpty [Char]) Object
-> Validation (NonEmpty [Char]) Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Validation (NonEmpty [Char]) Object
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax Object
obj
    Object
x -> Object -> Validation (NonEmpty [Char]) Object
forall a. a -> Validation (NonEmpty [Char]) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
x

instance CheckableSyntaxInitially Attribute
instance CheckableSyntaxInitially AttributeSugar
instance CheckableSyntaxInitially RuleAttribute
instance CheckableSyntaxInitially PeeledObject
instance CheckableSyntaxInitially ObjectHead
instance CheckableSyntaxInitially MetaId

class SugarableFinally a where
  sugarFinally :: a -> a
  sugarFinally = a -> a
forall a. a -> a
id

instance SugarableFinally Program where
  sugarFinally :: Program -> Program
  sugarFinally :: Program -> Program
sugarFinally (Program [Binding]
bindings) = [Binding] -> Program
Program ([Binding] -> [Binding]
forall a. SugarableFinally a => a -> a
sugarFinally [Binding]
bindings)

pattern SugarBinding :: Bytes -> Binding
pattern $mSugarBinding :: forall {r}. Binding -> (Bytes -> r) -> ((# #) -> r) -> r
SugarBinding bs <- AlphaBinding' "as-bytes" (Application "Φ.org.eolang.bytes" [AlphaBinding' "α0" (Formation [DeltaBinding bs])])

instance SugarableFinally Object where
  sugarFinally :: Object -> Object
  sugarFinally :: Object -> Object
sugarFinally = \case
    Application Object
"Φ.org.eolang.int" [SugarBinding Bytes
bs] -> Integer -> Object
ConstInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Int
bytesToInt Bytes
bs))
    Application Object
"Φ.org.eolang.i64" [SugarBinding Bytes
bs] -> Integer -> Object
ConstInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Int
bytesToInt Bytes
bs))
    Application Object
"Φ.org.eolang.i32" [SugarBinding Bytes
bs] -> Integer -> Object
ConstInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Int
bytesToInt Bytes
bs))
    Application Object
"Φ.org.eolang.i16" [SugarBinding Bytes
bs] -> Integer -> Object
ConstInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Int
bytesToInt Bytes
bs))
    Application Object
"Φ.org.eolang.float" [SugarBinding Bytes
bs] -> Double -> Object
ConstFloat (Bytes -> Double
bytesToFloat Bytes
bs)
    Application Object
"Φ.org.eolang.number" [SugarBinding Bytes
bs] -> Double -> Object
ConstFloat (Bytes -> Double
bytesToFloat Bytes
bs)
    Application Object
"Φ.org.eolang.string" [SugarBinding Bytes
bs] -> [Char] -> Object
ConstString (Bytes -> [Char]
bytesToString Bytes
bs)
    Object
"Φ.org.eolang" -> Object
GlobalObjectPhiOrg
    obj :: Object
obj@ConstString{} -> Object
obj
    obj :: Object
obj@ConstStringRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
    obj :: Object
obj@ConstInt{} -> Object
obj
    obj :: Object
obj@ConstIntRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
    obj :: Object
obj@ConstFloat{} -> Object
obj
    obj :: Object
obj@ConstFloatRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
    Formation [Binding]
bindings -> [Binding] -> Object
Formation ([Binding] -> [Binding]
forall a. SugarableFinally a => a -> a
sugarFinally [Binding]
bindings)
    Application Object
obj [Binding]
bindings -> Object -> [Binding] -> Object
Application (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj) (ApplicationBindings -> ApplicationBindings
forall a. SugarableFinally a => a -> a
sugarFinally ([Binding] -> ApplicationBindings
ApplicationBindings [Binding]
bindings)).applicationBindings
    ObjectDispatch Object
obj Attribute
a -> Object -> Attribute -> Object
ObjectDispatch (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj) Attribute
a
    Object
GlobalObject -> Object
GlobalObject
    obj :: Object
obj@Object
GlobalObjectPhiOrg -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
    Object
ThisObject -> Object
ThisObject
    Object
Termination -> Object
Termination
    MetaSubstThis Object
obj Object
this -> Object -> Object -> Object
MetaSubstThis (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj) (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
this)
    obj :: Object
obj@MetaObject{} -> Object
obj
    MetaContextualize Object
obj1 Object
obj2 -> Object -> Object -> Object
MetaContextualize (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj1) (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj2)
    MetaTailContext Object
obj TailMetaId
metaId -> Object -> TailMetaId -> Object
MetaTailContext (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj) TailMetaId
metaId
    MetaFunction MetaFunctionName
name Object
obj -> MetaFunctionName -> Object -> Object
MetaFunction MetaFunctionName
name (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj)

instance (SugarableFinally a) => SugarableFinally [a] where
  sugarFinally :: [a] -> [a]
sugarFinally = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. SugarableFinally a => a -> a
sugarFinally

newtype ApplicationBindings = ApplicationBindings {ApplicationBindings -> [Binding]
applicationBindings :: [Binding]}

instance SugarableFinally ApplicationBindings where
  sugarFinally :: ApplicationBindings -> ApplicationBindings
  sugarFinally :: ApplicationBindings -> ApplicationBindings
sugarFinally (ApplicationBindings [Binding]
bs) =
    [Binding] -> ApplicationBindings
ApplicationBindings ([Binding] -> ApplicationBindings)
-> [Binding] -> ApplicationBindings
forall a b. (a -> b) -> a -> b
$
      if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Int -> Binding -> Bool) -> [Int] -> [Binding] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Binding -> Bool
go [Int
0 ..] [Binding]
bs)
        then (\(~(AlphaBinding AttributeSugar
_ Object
obj)) -> Object -> Binding
AlphaBindingSugar (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj)) (Binding -> Binding) -> [Binding] -> [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
bs
        else [Binding] -> [Binding]
forall a. SugarableFinally a => a -> a
sugarFinally [Binding]
bs
   where
    go :: Int -> Binding -> Bool
    go :: Int -> Binding -> Bool
go Int
idx = \case
      obj :: Binding
obj@AlphaBindingSugar{} -> Binding -> Bool
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
obj
      obj :: Binding
obj@AlphaBinding''{} -> Binding -> Bool
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
obj
      AlphaBinding' (Alpha (AlphaIndex (Char
'α' : [Char]
idx'))) Object
_ -> Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
idx'
      Binding
_ -> Bool
False

instance SugarableFinally Binding where
  sugarFinally :: Binding -> Binding
  sugarFinally :: Binding -> Binding
sugarFinally = \case
    obj :: Binding
obj@AlphaBindingSugar{} -> Binding -> Binding
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
obj
    obj :: Binding
obj@AlphaBinding''{} -> Binding -> Binding
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
obj
    AlphaBinding' a :: Attribute
a@(Label LabelId
l) (Formation [Binding]
bs) ->
      case ([Binding], [Binding])
es of
        ([], [Binding]
_) -> Attribute -> Object -> Binding
AlphaBinding' Attribute
a (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally ([Binding] -> Object
Formation [Binding]
bs))
        ([Binding]
es', [Binding]
es'') -> LabelId -> [Attribute] -> Object -> Binding
AlphaBinding'' LabelId
l ((\(~(EmptyBinding Attribute
e)) -> Attribute
e) (Binding -> Attribute) -> [Binding] -> [Attribute]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
es') (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally ([Binding] -> Object
Formation [Binding]
es''))
     where
      es :: ([Binding], [Binding])
es = (Binding -> Bool) -> [Binding] -> ([Binding], [Binding])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\case EmptyBinding Attribute
_ -> Bool
True; Binding
_ -> Bool
False) [Binding]
bs
    AlphaBinding AttributeSugar
a Object
obj -> AttributeSugar -> Object -> Binding
AlphaBinding AttributeSugar
a (Object -> Object
forall a. SugarableFinally a => a -> a
sugarFinally Object
obj)
    Binding
x -> Binding
x

instance SugarableFinally ObjectMetaId
instance SugarableFinally BindingsMetaId
instance SugarableFinally LabelMetaId
instance SugarableFinally BytesMetaId
instance SugarableFinally Attribute
instance SugarableFinally TailMetaId
instance SugarableFinally Bytes
instance SugarableFinally MetaId

desugar :: Object -> Object
desugar :: Object -> Object
desugar = \case
  ConstString [Char]
string -> Bytes -> Object
wrapBytesInString ([Char] -> Bytes
stringToBytes [Char]
string)
  obj :: Object
obj@ConstStringRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  ConstInt Integer
n -> Bytes -> Object
wrapBytesInInt (Int -> Bytes
intToBytes (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))
  obj :: Object
obj@ConstIntRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  ConstFloat Double
x -> Bytes -> Object
wrapBytesInFloat (Double -> Bytes
floatToBytes Double
x)
  obj :: Object
obj@ConstFloatRaw{} -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  Formation [Binding]
bindings -> [Binding] -> Object
Formation (Binding -> Binding
desugarBinding (Binding -> Binding) -> [Binding] -> [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
bindings)
  Application Object
obj [Binding]
bindings -> Object -> [Binding] -> Object
Application (Object -> Object
desugar Object
obj) (Binding -> Binding
desugarBinding (Binding -> Binding) -> [Binding] -> [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
bindings)
  ObjectDispatch Object
obj Attribute
a -> Object -> Attribute -> Object
ObjectDispatch (Object -> Object
desugar Object
obj) Attribute
a
  Object
GlobalObject -> Object
GlobalObject
  obj :: Object
obj@Object
GlobalObjectPhiOrg -> Object -> Object
forall a. Object -> a
errorExpectedDesugaredObject Object
obj
  Object
ThisObject -> Object
ThisObject
  Object
Termination -> Object
Termination
  MetaSubstThis Object
obj Object
this -> Object -> Object -> Object
MetaSubstThis (Object -> Object
desugar Object
obj) (Object -> Object
desugar Object
this)
  obj :: Object
obj@MetaObject{} -> Object
obj
  MetaContextualize Object
obj1 Object
obj2 -> Object -> Object -> Object
MetaContextualize (Object -> Object
desugar Object
obj1) (Object -> Object
desugar Object
obj2)
  MetaTailContext Object
obj TailMetaId
metaId -> Object -> TailMetaId -> Object
MetaTailContext (Object -> Object
desugar Object
obj) TailMetaId
metaId
  MetaFunction MetaFunctionName
name Object
obj -> MetaFunctionName -> Object -> Object
MetaFunction MetaFunctionName
name (Object -> Object
desugar Object
obj)

desugarBinding :: Binding -> Binding
desugarBinding :: Binding -> Binding
desugarBinding = \case
  AlphaBinding'' LabelId
l [Attribute]
ls (Formation [Binding]
bindings) ->
    let bindingsDesugared :: [Binding]
bindingsDesugared = Binding -> Binding
desugarBinding (Binding -> Binding) -> [Binding] -> [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
bindings
     in Attribute -> Object -> Binding
AlphaBinding' (LabelId -> Attribute
Label LabelId
l) ([Binding] -> Object
Formation ((Attribute -> Binding
EmptyBinding (Attribute -> Binding) -> [Attribute] -> [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attribute]
ls) [Binding] -> [Binding] -> [Binding]
forall a. Semigroup a => a -> a -> a
<> [Binding]
bindingsDesugared))
  AlphaBinding' Attribute
l (Formation [Binding]
bindings) ->
    let bindingsDesugared :: [Binding]
bindingsDesugared = Binding -> Binding
desugarBinding (Binding -> Binding) -> [Binding] -> [Binding]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
bindings
     in Attribute -> Object -> Binding
AlphaBinding' Attribute
l ([Binding] -> Object
Formation [Binding]
bindingsDesugared)
  AlphaBinding AttributeSugar
a Object
obj -> AttributeSugar -> Object -> Binding
AlphaBinding AttributeSugar
a (Object -> Object
desugar Object
obj)
  obj :: Binding
obj@(AlphaBindingSugar{}) -> Binding -> Binding
forall a. Binding -> a
errorExpectedDesugaredBinding Binding
obj
  Binding
binding -> Binding
binding

-- MetaSubstThis

wrapBytesInInt :: Bytes -> Object
wrapBytesInInt :: Bytes -> Object
wrapBytesInInt (Bytes [Char]
bytes) = [fmt|Φ.org.eolang.i64(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bytes} ⟧))|]
wrapBytesInFloat :: Bytes -> Object
wrapBytesInFloat :: Bytes -> Object
wrapBytesInFloat (Bytes [Char]
bytes) = [fmt|Φ.org.eolang.number(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bytes} ⟧))|]
wrapBytesInString :: Bytes -> Object
wrapBytesInString :: Bytes -> Object
wrapBytesInString (Bytes [Char]
bytes) = [fmt|Φ.org.eolang.string(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bytes} ⟧))|]
wrapBytesInBytes :: Bytes -> Object
wrapBytesInBytes :: Bytes -> Object
wrapBytesInBytes (Bytes [Char]
bytes) = [fmt|Φ.org.eolang.bytes(⟦ Δ ⤍ {bytes} ⟧)|]
wrapTermination :: Object
wrapTermination :: Object
wrapTermination = [fmt|Φ.org.eolang.error(α0 ↦ Φ.org.eolang.string(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bytes} ⟧)))|]
 where
  Bytes [Char]
bytes = [Char] -> Bytes
stringToBytes [Char]
"unknown error"

wrapBytesInConstInt :: Bytes -> Object
wrapBytesInConstInt :: Bytes -> Object
wrapBytesInConstInt = Bytes -> Object
wrapBytesInConstInt64

wrapBytesInConstInt64 :: Bytes -> Object
wrapBytesInConstInt64 :: Bytes -> Object
wrapBytesInConstInt64 bytes :: Bytes
bytes@(Bytes [Char]
bs)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [fmt|Φ.org.eolang.i64(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bs} ⟧))|]
  | Bool
otherwise = [fmt|Φ.org.eolang.i64(as-bytes ↦ {n})|]
 where
  n :: Int
n = Bytes -> Int
bytesToInt Bytes
bytes

wrapBytesInConstInt32 :: Bytes -> Object
wrapBytesInConstInt32 :: Bytes -> Object
wrapBytesInConstInt32 bytes :: Bytes
bytes@(Bytes [Char]
bs)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [fmt|Φ.org.eolang.i32(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bs} ⟧))|]
  | Bool
otherwise = [fmt|Φ.org.eolang.i32(as-bytes ↦ {n})|]
 where
  n :: Int
n = Bytes -> Int
bytesToInt Bytes
bytes

wrapBytesInConstInt16 :: Bytes -> Object
wrapBytesInConstInt16 :: Bytes -> Object
wrapBytesInConstInt16 bytes :: Bytes
bytes@(Bytes [Char]
bs)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = [fmt|Φ.org.eolang.i16(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bs} ⟧))|]
  | Bool
otherwise = [fmt|Φ.org.eolang.i16(as-bytes ↦ {n})|]
 where
  n :: Int
n = Bytes -> Int
bytesToInt Bytes
bytes

wrapBytesInConstFloat :: Bytes -> Object
wrapBytesInConstFloat :: Bytes -> Object
wrapBytesInConstFloat bytes :: Bytes
bytes@(Bytes [Char]
bs)
  | Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 = [fmt|Φ.org.eolang.number(as-bytes ↦ 0.0)|]
  | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double -> Int
isDoubleFinite Double
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [fmt|Φ.org.eolang.number(as-bytes ↦ {printf "%f" x :: String})|]
  | Bool
otherwise = [fmt|Φ.org.eolang.number(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bs} ⟧))|]
 where
  x :: Double
x = Bytes -> Double
bytesToFloat Bytes
bytes

wrapBytesInConstString :: Bytes -> Object
wrapBytesInConstString :: Bytes -> Object
wrapBytesInConstString bytes :: Bytes
bytes@(Bytes [Char]
bs)
  | Char
'\\' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
s = [fmt|Φ.org.eolang.string(as-bytes ↦ Φ.org.eolang.bytes(⟦ Δ ⤍ {bs} ⟧))|]
  | Bool
otherwise = [fmt|Φ.org.eolang.string(as-bytes ↦ {s})|]
 where
  s :: [Char]
s = [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Bytes -> [Char]
bytesToString Bytes
bytes)

wrapBytesAsBool :: Bytes -> Object
wrapBytesAsBool :: Bytes -> Object
wrapBytesAsBool Bytes
bytes
  | Bytes -> Int
bytesToInt Bytes
bytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [fmt|Φ.org.eolang.false|]
  | Bool
otherwise = [fmt|Φ.org.eolang.true|]

padLeft :: Int -> [Char] -> [Char]
padLeft :: Int -> [Char] -> [Char]
padLeft Int
n [Char]
s = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

-- | Split a list into chunks of given size.
-- All lists in the result are guaranteed to have length less than or equal to the given size.
--
-- >>> chunksOf 2 "012345678"
-- ["01","23","45","67","8"]
--
-- See 'paddedLeftChunksOf' for a version with padding to guarantee exact chunk size.
chunksOf :: Int -> [a] -> [[a]]
chunksOf :: forall a. Int -> [a] -> [[a]]
chunksOf Int
_ [] = []
chunksOf Int
n [a]
xs = [a]
chunk [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunksOf Int
n [a]
leftover
 where
  ([a]
chunk, [a]
leftover) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs

-- | Split a list into chunks of given size,
-- padding on the left if necessary.
-- All lists in the result are guaranteed to have given size.
--
-- >>> paddedLeftChunksOf '0' 2 "1234567"
-- ["01","23","45","67"]
-- >>> paddedLeftChunksOf '0' 2 "123456"
-- ["12","34","56"]
--
-- prop> n > 0  ==>  all (\chunk -> length chunk == n) (paddedLeftChunksOf c n s)
paddedLeftChunksOf :: a -> Int -> [a] -> [[a]]
paddedLeftChunksOf :: forall a. a -> Int -> [a] -> [[a]]
paddedLeftChunksOf a
padSymbol Int
n [a]
xs
  | Int
padSize Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunksOf Int
n [a]
xs
  | Bool
otherwise = Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
chunksOf Int
n (Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
padSize a
padSymbol [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs)
 where
  len :: Int
len = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
  padSize :: Int
padSize = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n

-- | Normalize the bytestring representation to fit valid 'Bytes' token.
--
-- >>> normalizeBytes "238714ABCDEF"
-- "23-87-14-AB-CD-EF"
--
-- >>> normalizeBytes "0238714ABCDEF"
-- "00-23-87-14-AB-CD-EF"
--
-- >>> normalizeBytes "4"
-- "04-"
normalizeBytes :: String -> String
normalizeBytes :: [Char] -> [Char]
normalizeBytes = [[Char]] -> [Char]
withDashes ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int -> [Char] -> [[Char]]
forall a. a -> Int -> [a] -> [[a]]
paddedLeftChunksOf Char
'0' Int
2 ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper
 where
  withDashes :: [[Char]] -> [Char]
withDashes = \case
    [] -> [Char]
"00-"
    [[Char]
byte] -> [Char]
byte [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"-"
    [[Char]]
bytes -> [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"-" [[Char]]
bytes

-- | Concatenate 'Bytes'.
-- FIXME: we should really use 'ByteString' instead of the underlying 'String' representation.
--
-- >>> concatBytes "00-" "01-02"
-- Bytes "00-01-02"
--
-- >>> concatBytes "03-04" "01-02"
-- Bytes "03-04-01-02"
--
-- >>> concatBytes "03-04" "01-"
-- Bytes "03-04-01"
concatBytes :: Bytes -> Bytes -> Bytes
concatBytes :: Bytes -> Bytes -> Bytes
concatBytes (Bytes [Char]
xs) (Bytes [Char]
zs) = [Char] -> Bytes
Bytes ([Char] -> [Char]
normalizeBytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') ([Char]
xs [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
zs)))

-- | Select a slice (section) of 'Bytes'.
--
-- >>> sliceBytes "12-34-56" 1 1
-- Bytes "34-"
--
-- >>> sliceBytes "12-34-56" 1 0
-- Bytes "00-"
--
-- >>> sliceBytes "12-34-56" 0 2
-- Bytes "12-34"
sliceBytes :: Bytes -> Int -> Int -> Bytes
sliceBytes :: Bytes -> Int -> Int -> Bytes
sliceBytes (Bytes [Char]
bytes) Int
start Int
len = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
len) (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
start) ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
bytes))

-- | Convert an 'Int' into 'Bytes' representation.
--
-- >>> intToBytes 7
-- Bytes "00-00-00-00-00-00-00-07"
-- >>> intToBytes (3^33)
-- Bytes "00-13-BF-EF-A6-5A-BB-83"
-- >>> intToBytes (-1)
-- Bytes "FF-FF-FF-FF-FF-FF-FF-FF"
intToBytes :: Int -> Bytes
intToBytes :: Int -> Bytes
intToBytes Int
n = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.Strict.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Int
n

-- | Convert an 'Int64' into 'Bytes' representation.
--
-- >>> int64ToBytes 7
-- Bytes "00-00-00-00-00-00-00-07"
-- >>> int64ToBytes (3^33)
-- Bytes "00-13-BF-EF-A6-5A-BB-83"
-- >>> int64ToBytes (-1)
-- Bytes "FF-FF-FF-FF-FF-FF-FF-FF"
int64ToBytes :: Int64 -> Bytes
int64ToBytes :: Int64 -> Bytes
int64ToBytes Int64
n = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.Strict.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Int64
n

-- | Convert an 'Int32' into 'Bytes' representation.
--
-- >>> int32ToBytes 7
-- Bytes "00-00-00-07"
-- >>> int32ToBytes (3^33)
-- Bytes "A6-5A-BB-83"
-- >>> int32ToBytes (-1)
-- Bytes "FF-FF-FF-FF"
int32ToBytes :: Int32 -> Bytes
int32ToBytes :: Int32 -> Bytes
int32ToBytes Int32
n = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.Strict.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int32 -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Int32
n

-- | Convert an 'Int16' into 'Bytes' representation.
--
-- >>> int16ToBytes 7
-- Bytes "00-07"
-- >>> int16ToBytes (3^33)
-- Bytes "BB-83"
-- >>> int16ToBytes (-1)
-- Bytes "FF-FF"
int16ToBytes :: Int16 -> Bytes
int16ToBytes :: Int16 -> Bytes
int16ToBytes Int16
n = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.Strict.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int16 -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Int16
n

-- | Parse 'Bytes' as 'Int'.
--
-- >>> bytesToInt "00-13-BF-EF-A6-5A-BB-83"
-- 5559060566555523
-- >>> bytesToInt "AB-"
-- 171
--
-- May error on invalid 'Bytes':
--
-- >>> bytesToInt "s"
-- *** Exception: Prelude.head: empty list
-- ...
-- ...
-- ...
-- ...
-- ...
-- ...
bytesToInt :: Bytes -> Int
bytesToInt :: Bytes -> Int
bytesToInt (Bytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') -> [Char]
bytes))
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
bytes = Int
0
  | Bool
otherwise = (Int, [Char]) -> Int
forall a b. (a, b) -> a
fst ((Int, [Char]) -> Int) -> (Int, [Char]) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, [Char])] -> (Int, [Char])
forall a. HasCallStack => [a] -> a
head ([(Int, [Char])] -> (Int, [Char]))
-> [(Int, [Char])] -> (Int, [Char])
forall a b. (a -> b) -> a -> b
$ ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex [Char]
bytes

-- | Parse 'Bytes' as 'Int64'.
--
-- >>> bytesToInt64 "00-13-BF-EF-A6-5A-BB-83"
-- 5559060566555523
-- >>> bytesToInt64 "AB-"
-- 171
--
-- May error on invalid 'Bytes':
--
-- >>> bytesToInt64 "s"
-- *** Exception: Prelude.head: empty list
-- ...
-- ...
-- ...
-- ...
-- ...
-- ...
bytesToInt64 :: Bytes -> Int64
bytesToInt64 :: Bytes -> Int64
bytesToInt64 (Bytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') -> [Char]
bytes))
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
bytes = Int64
0
  | Bool
otherwise = (Int64, [Char]) -> Int64
forall a b. (a, b) -> a
fst ((Int64, [Char]) -> Int64) -> (Int64, [Char]) -> Int64
forall a b. (a -> b) -> a -> b
$ [(Int64, [Char])] -> (Int64, [Char])
forall a. HasCallStack => [a] -> a
head ([(Int64, [Char])] -> (Int64, [Char]))
-> [(Int64, [Char])] -> (Int64, [Char])
forall a b. (a -> b) -> a -> b
$ ReadS Int64
forall a. (Eq a, Num a) => ReadS a
readHex [Char]
bytes

-- | Parse 'Bytes' as 'Int32'.
--
-- >>> bytesToInt32 "A6-5A-BB-83"
-- -1504003197
-- >>> bytesToInt32 "AB-"
-- 171
--
-- May error on invalid 'Bytes':
--
-- >>> bytesToInt32 "s"
-- *** Exception: Prelude.head: empty list
-- ...
-- ...
-- ...
-- ...
-- ...
-- ...
bytesToInt32 :: Bytes -> Int32
bytesToInt32 :: Bytes -> Int32
bytesToInt32 (Bytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') -> [Char]
bytes))
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
bytes = Int32
0
  | Bool
otherwise = (Int32, [Char]) -> Int32
forall a b. (a, b) -> a
fst ((Int32, [Char]) -> Int32) -> (Int32, [Char]) -> Int32
forall a b. (a -> b) -> a -> b
$ [(Int32, [Char])] -> (Int32, [Char])
forall a. HasCallStack => [a] -> a
head ([(Int32, [Char])] -> (Int32, [Char]))
-> [(Int32, [Char])] -> (Int32, [Char])
forall a b. (a -> b) -> a -> b
$ ReadS Int32
forall a. (Eq a, Num a) => ReadS a
readHex [Char]
bytes

-- | Parse 'Bytes' as 'Int16'.
--
-- >>> bytesToInt16 "BB-83"
-- -17533
-- >>> bytesToInt16 "AB-"
-- 171
--
-- May error on invalid 'Bytes':
--
-- >>> bytesToInt16 "s"
-- *** Exception: Prelude.head: empty list
-- ...
-- ...
-- ...
-- ...
-- ...
-- ...
bytesToInt16 :: Bytes -> Int16
bytesToInt16 :: Bytes -> Int16
bytesToInt16 (Bytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') -> [Char]
bytes))
  | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
bytes = Int16
0
  | Bool
otherwise = (Int16, [Char]) -> Int16
forall a b. (a, b) -> a
fst ((Int16, [Char]) -> Int16) -> (Int16, [Char]) -> Int16
forall a b. (a -> b) -> a -> b
$ [(Int16, [Char])] -> (Int16, [Char])
forall a. HasCallStack => [a] -> a
head ([(Int16, [Char])] -> (Int16, [Char]))
-> [(Int16, [Char])] -> (Int16, [Char])
forall a b. (a -> b) -> a -> b
$ ReadS Int16
forall a. (Eq a, Num a) => ReadS a
readHex [Char]
bytes

-- | Convert 'Bool' to 'Bytes'.
--
-- >>> boolToBytes False
-- Bytes "00-"
-- >>> boolToBytes True
-- Bytes "01-"
boolToBytes :: Bool -> Bytes
boolToBytes :: Bool -> Bytes
boolToBytes Bool
True = [Char] -> Bytes
Bytes [Char]
"01-"
boolToBytes Bool
False = [Char] -> Bytes
Bytes [Char]
"00-"

-- | Interpret 'Bytes' as 'Bool'.
--
-- Zero is interpreted as 'False'.
--
-- >>> bytesToBool "00-"
-- False
--
-- >>> bytesToBool "00-00"
-- False
--
-- Everything else is interpreted as 'True'.
--
-- >>> bytesToBool "01-"
-- True
--
-- >>> bytesToBool "00-01"
-- True
--
-- >>> bytesToBool "AB-CD"
-- True
bytesToBool :: Bytes -> Bool
bytesToBool :: Bytes -> Bool
bytesToBool (Bytes ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') -> [])) = Bool
False
bytesToBool Bytes
_ = Bool
True

-- | Encode 'String' as 'Bytes'.
--
-- >>> stringToBytes "Hello, world!"
-- Bytes "48-65-6C-6C-6F-2C-20-77-6F-72-6C-64-21"
--
-- >>> stringToBytes "Привет, мир!"
-- Bytes "D0-9F-D1-80-D0-B8-D0-B2-D0-B5-D1-82-2C-20-D0-BC-D0-B8-D1-80-21"
--
-- >>> stringToBytes  "hello, 大家!"
-- Bytes "68-65-6C-6C-6F-2C-20-E5-A4-A7-E5-AE-B6-21"
stringToBytes :: String -> Bytes
stringToBytes :: [Char] -> Bytes
stringToBytes [Char]
s = ByteString -> Bytes
bytestringToBytes (ByteString -> Bytes) -> ByteString -> Bytes
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 ([Char] -> Text
Text.pack [Char]
s)

bytestringToBytes :: ByteString -> Bytes
bytestringToBytes :: ByteString -> Bytes
bytestringToBytes = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> (ByteString -> [Char]) -> ByteString -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
normalizeBytes ([Char] -> [Char])
-> (ByteString -> [Char]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char])
-> (ByteString -> [Word8]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
ByteString.Strict.unpack

bytesToByteString :: Bytes -> ByteString
bytesToByteString :: Bytes -> ByteString
bytesToByteString (Bytes [Char]
bytes) = [Word8] -> ByteString
ByteString.Strict.pack ([Char] -> [Word8]
forall {a}. (Eq a, Num a) => [Char] -> [a]
go ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') [Char]
bytes))
 where
  go :: [Char] -> [a]
go [] = []
  go (Char
x : Char
y : [Char]
xs) = (a, [Char]) -> a
forall a b. (a, b) -> a
fst ([(a, [Char])] -> (a, [Char])
forall a. HasCallStack => [a] -> a
head (ReadS a
forall a. (Eq a, Num a) => ReadS a
readHex [Char
x, Char
y])) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Char] -> [a]
go [Char]
xs
  go [Char
_] = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: partial byte"

-- | Decode 'String' from 'Bytes'.
--
-- >>> bytesToString "48-65-6C-6C-6F-2C-20-77-6F-72-6C-64-21"
-- "Hello, world!"
bytesToString :: Bytes -> String
bytesToString :: Bytes -> [Char]
bytesToString = Text -> [Char]
Text.unpack (Text -> [Char]) -> (Bytes -> Text) -> Bytes -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (Bytes -> ByteString) -> Bytes -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> ByteString
bytesToByteString

-- | Encode 'Double' as 'Bytes' following IEEE754.
--
-- Note: it is called "float" in EO, but it actually occupies 8 bytes so it corresponds to 'Double'.
--
-- >>> floatToBytes 0
-- Bytes "00-00-00-00-00-00-00-00"
--
-- >>> floatToBytes (-0.1)
-- Bytes "BF-B9-99-99-99-99-99-9A"
--
-- >>> floatToBytes (1/0)       -- Infinity
-- Bytes "7F-F0-00-00-00-00-00-00"
--
-- >>> floatToBytes (asin 2) `elem` ["FF-F8-00-00-00-00-00-00", "7F-F8-00-00-00-00-00-00"]  -- sNaN or qNaN
-- True
floatToBytes :: Double -> Bytes
floatToBytes :: Double -> Bytes
floatToBytes Double
f = [Char] -> Bytes
Bytes ([Char] -> Bytes) -> [Char] -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
normalizeBytes ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Word8 -> [Char]) -> [Word8] -> [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> [Char] -> [Char]
padLeft Int
2 ([Char] -> [Char]) -> (Word8 -> [Char]) -> Word8 -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
`showHex` [Char]
"")) ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
ByteString.Strict.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Double -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode Double
f

-- | Decode 'Double' from 'Bytes' following IEEE754.
--
-- >>> bytesToFloat "00-00-00-00-00-00-00-00"
-- 0.0
--
-- >>> bytesToFloat "BF-B9-99-99-99-99-99-9A"
-- -0.1
--
-- >>> bytesToFloat "7F-F0-00-00-00-00-00-00"
-- Infinity
--
-- >>> bytesToFloat "FF-F8-00-00-00-00-00-00"
-- NaN
bytesToFloat :: Bytes -> Double
bytesToFloat :: Bytes -> Double
bytesToFloat (Bytes [Char]
bytes) =
  case ByteString -> Either [Char] Double
forall a. Serialize a => ByteString -> Either [Char] a
Serialize.decode (ByteString -> Either [Char] Double)
-> ByteString -> Either [Char] Double
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
ByteString.Strict.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ ([Char] -> Word8) -> [[Char]] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map ((Word8, [Char]) -> Word8
forall a b. (a, b) -> a
fst ((Word8, [Char]) -> Word8)
-> ([Char] -> (Word8, [Char])) -> [Char] -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Word8, [Char])] -> (Word8, [Char])
forall a. HasCallStack => [a] -> a
head ([(Word8, [Char])] -> (Word8, [Char]))
-> ([Char] -> [(Word8, [Char])]) -> [Char] -> (Word8, [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [(Word8, [Char])]
forall a. (Eq a, Num a) => ReadS a
readHex) ([[Char]] -> [Word8]) -> [[Char]] -> [Word8]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
dashToSpace [Char]
bytes) of
    Left [Char]
msg -> [Char] -> Double
forall a. HasCallStack => [Char] -> a
error [Char]
msg
    Right Double
x -> Double
x
 where
  dashToSpace :: Char -> Char
dashToSpace Char
'-' = Char
' '
  dashToSpace Char
c = Char
c

instance IsString Program where fromString :: [Char] -> Program
fromString = ([Token] -> Either [Char] Program) -> [Char] -> Program
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Program
pProgram
instance IsString Object where fromString :: [Char] -> Object
fromString = ([Token] -> Either [Char] Object) -> [Char] -> Object
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Object
pObject
instance IsString Binding where fromString :: [Char] -> Binding
fromString = ([Token] -> Either [Char] Binding) -> [Char] -> Binding
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Binding
pBinding
instance IsString Attribute where fromString :: [Char] -> Attribute
fromString = ([Token] -> Either [Char] Attribute) -> [Char] -> Attribute
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] Attribute
pAttribute
instance IsString AttributeSugar where fromString :: [Char] -> AttributeSugar
fromString = ([Token] -> Either [Char] AttributeSugar)
-> [Char] -> AttributeSugar
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] AttributeSugar
pAttributeSugar
instance IsString RuleAttribute where fromString :: [Char] -> RuleAttribute
fromString = ([Token] -> Either [Char] RuleAttribute) -> [Char] -> RuleAttribute
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] RuleAttribute
pRuleAttribute
instance IsString PeeledObject where fromString :: [Char] -> PeeledObject
fromString = ([Token] -> Either [Char] PeeledObject) -> [Char] -> PeeledObject
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] PeeledObject
pPeeledObject
instance IsString ObjectHead where fromString :: [Char] -> ObjectHead
fromString = ([Token] -> Either [Char] ObjectHead) -> [Char] -> ObjectHead
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] ObjectHead
pObjectHead
instance IsString MetaId where fromString :: [Char] -> MetaId
fromString = ([Token] -> Either [Char] MetaId) -> [Char] -> MetaId
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] MetaId
pMetaId

parseWith :: (DesugarableInitially a, CheckableSyntaxInitially a) => ([Token] -> Either String a) -> String -> Either String a
parseWith :: forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> Either [Char] a
parseWith [Token] -> Either [Char] a
parser [Char]
input = Either [Char] a
result
 where
  input' :: [Char]
input' = [Char] -> [Char]
preprocess [Char]
input
  tokens :: [Token]
tokens = [Char] -> [Token]
myLexer [Char]
input'
  parsed :: Either [Char] a
parsed = [Token] -> Either [Char] a
parser [Token]
tokens
  validated :: Either [Char] (Validation (NonEmpty [Char]) a)
validated = a -> Validation (NonEmpty [Char]) a
forall a.
CheckableSyntaxInitially a =>
a -> Validation (NonEmpty [Char]) a
checkSyntax (a -> Validation (NonEmpty [Char]) a)
-> Either [Char] a
-> Either [Char] (Validation (NonEmpty [Char]) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [Char] a
parsed
  mkError :: String -> Either String a
  mkError :: forall a. [Char] -> Either [Char] a
mkError [Char]
x = [Char] -> Either [Char] a
forall a b. a -> Either a b
Left [fmt|{x}\non the input:\n{input'}|]
  result :: Either [Char] a
result =
    case Either [Char] (Validation (NonEmpty [Char]) a)
validated of
      Left [Char]
x -> [Char] -> Either [Char] a
forall a. [Char] -> Either [Char] a
mkError [Char]
x
      Right Validation (NonEmpty [Char]) a
x ->
        case Validation (NonEmpty [Char]) a
x of
          Failure NonEmpty [Char]
y -> [Char] -> Either [Char] a
forall a. [Char] -> Either [Char] a
mkError [fmt|Bad sub-expressions:\n\n{intercalate1 "\n\n" y}\n|]
          Success a
y -> a -> Either [Char] a
forall a b. b -> Either a b
Right (a -> a
forall a. DesugarableInitially a => a -> a
desugarInitially a
y)

-- | Parse an 'Object' from a 'String'.
-- May throw an 'error` if input has a syntactical or lexical errors.
unsafeParseWith :: (DesugarableInitially a, CheckableSyntaxInitially a) => ([Token] -> Either String a) -> String -> a
unsafeParseWith :: forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> a
unsafeParseWith [Token] -> Either [Char] a
parser [Char]
input =
  case ([Token] -> Either [Char] a) -> [Char] -> Either [Char] a
forall a.
(DesugarableInitially a, CheckableSyntaxInitially a) =>
([Token] -> Either [Char] a) -> [Char] -> Either [Char] a
parseWith [Token] -> Either [Char] a
parser [Char]
input of
    Left [Char]
parseError -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
parseError
    Right a
object -> a
object

printTreeDontSugar :: (Pretty a) => a -> String
printTreeDontSugar :: forall a. Pretty a => a -> [Char]
printTreeDontSugar =
  Text -> [Char]
T.unpack
    (Text -> [Char]) -> (a -> Text) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict
    (SimpleDocStream Any -> Text)
-> (a -> SimpleDocStream Any) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions{layoutPageWidth = Unbounded}
    (Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

-- | The top-level printing method.
printTree :: (Pretty a, SugarableFinally a) => a -> String
printTree :: forall a. (Pretty a, SugarableFinally a) => a -> [Char]
printTree =
  a -> [Char]
forall a. Pretty a => a -> [Char]
printTreeDontSugar
    (a -> [Char]) -> (a -> a) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. SugarableFinally a => a -> a
sugarFinally

-- >>> bytesToInt "00-00-00-00-00-00-00-00"
-- 0

pattern AlphaBinding' :: Attribute -> Object -> Binding
pattern $mAlphaBinding' :: forall {r}.
Binding -> (Attribute -> Object -> r) -> ((# #) -> r) -> r
$bAlphaBinding' :: Attribute -> Object -> Binding
AlphaBinding' a obj = AlphaBinding (AttributeNoSugar a) obj

pattern AlphaBinding'' :: LabelId -> [Attribute] -> Object -> Binding
pattern $mAlphaBinding'' :: forall {r}.
Binding
-> (LabelId -> [Attribute] -> Object -> r) -> ((# #) -> r) -> r
$bAlphaBinding'' :: LabelId -> [Attribute] -> Object -> Binding
AlphaBinding'' a as obj = AlphaBinding (AttributeSugar a as) obj

{-# COMPLETE AlphaBinding', AlphaBinding'', EmptyBinding, DeltaBinding, DeltaEmptyBinding, LambdaBinding, MetaBindings, MetaDeltaBinding, AlphaBindingSugar #-}