I’m tring to write a “metaprogramming” library for Elm.
The big idea is creating a Meta a type that describes how a type a is built.
One of the things that can be created from a Meta a type is a form: something of type a -> Html a.
During the implementation I got stuck because I’ve done something wrong somewhere and the browser process gets stuck at 100% and never recovers.
How does one debug this kind of errors? It’s probably an infinite loop, but I don’t know where to start debugging.
The loop can be reproduced by choosing a different value for the select.
Any additional feedback is obviously welcome!
Main.elm
module Main exposing (main)
import Html exposing (Html)
import Json.Decode as JD
import Pairs exposing (..)
type Adt
= Left String
| Right Int
cata : (String -> o) -> (Int -> o) -> Adt -> o
cata lf rf v =
case v of
Left l ->
lf l
Right r ->
rf r
adtMeta : Meta Adt
adtMeta =
adt cata cata
|> alternative1 "Left" Left string
|> alternative1 "Right" Right int
|> buildAdt (\_ -> Left "")
init : ( Model, Cmd Msg )
init =
let
model =
Right -1
in
( model, Cmd.none )
type alias Model =
Adt
type alias Msg =
Adt
main : Program Never Model Msg
main =
Html.program
{ init = init
, view = view
, update = update
, subscriptions = subscriptions
}
update : Msg -> Model -> ( Model, Cmd Msg )
update msg _ =
( msg, Cmd.none )
subscriptions : Model -> Sub Msg
subscriptions model =
Sub.none
view : Model -> Html Msg
view model =
let
encoded =
encoder adtMeta model
decoded =
JD.decodeValue (decoder adtMeta) encoded
in
Html.span []
[ Html.text "Encoded: "
, Html.text <| toString encoded
, Html.text " decoded: "
, case decoded of
Ok v ->
Html.text <| toString v
Err e ->
String.split "\n" e
|> List.map Html.text
|> List.intersperse (Html.br [] [])
|> Html.span []
, form adtMeta model
]
Pairs.elm
module Pairs
exposing
( Meta
, ObjectMeta
, adt
, alternative0
, alternative1
, alternative2
, array
, bool
, buildAdt
, buildObject
, decoder
, default
, description
, dict
, encoder
, field
, float
, form
, int
, object
, string
)
import Array exposing (Array)
import Dict exposing (Dict)
import Html exposing (Html)
import Json.Decode as JD exposing (Decoder)
import Json.Encode as JE exposing (Value)
import Pairs.Form as Form
type Meta a
= Meta
{ encoder : a -> Value
, decoder : () -> Decoder a
, description : () -> Description
, form : a -> Html a
, default : () -> a
}
decoder : Meta a -> Decoder a
decoder (Meta m) =
m.decoder ()
encoder : Meta a -> a -> Value
encoder (Meta m) =
m.encoder
description : Meta a -> Description
description (Meta m) =
m.description ()
form : Meta a -> a -> Html a
form (Meta m) =
m.form
default : Meta a -> a
default (Meta m) =
m.default ()
type Description
= Bool
| Float
| Int
| String
| Array Description
| Dict Description
| Tuple Description Description
| Adt (Dict String (Array Description))
| Recursive (Description -> Description)
| Object (Dict String Description)
--Base
string : Meta String
string =
Meta
{ encoder = JE.string
, decoder = \_ -> JD.string
, description = \_ -> String
, form = Form.string
, default = \_ -> ""
}
int : Meta Int
int =
Meta
{ encoder = JE.int
, decoder = \_ -> JD.int
, description = \_ -> Int
, form = Form.int
, default = \_ -> 0
}
float : Meta Float
float =
Meta
{ encoder = JE.float
, decoder = \_ -> JD.float
, description = \_ -> Float
, form = Form.float
, default = \_ -> 0.0
}
bool : Meta Bool
bool =
Meta
{ encoder = JE.bool
, decoder = \_ -> JD.bool
, description = \_ -> Bool
, form = Form.bool
, default = \_ -> False
}
-- Composite
array : Meta a -> Meta (Array a)
array meta =
Meta
{ encoder = \v -> JE.array <| Array.map (encoder meta) <| v
, decoder = \_ -> JD.array <| decoder meta
, description = \_ -> Array <| description meta
, form = Form.array (form meta) (default meta)
, default = \_ -> Array.empty
}
dict : Meta a -> Meta (Dict String a)
dict meta =
Meta
{ encoder = \v -> JE.object <| Dict.toList <| Dict.map (always <| encoder meta) v
, decoder = \_ -> JD.dict <| decoder meta
, description = \_ -> Dict <| description meta
, form = \model -> form meta |> Debug.crash "unfinished"
, default = \_ -> Dict.empty
}
--RECORDS
type ObjectMeta a b
= ObjectMeta
{ encoder : a -> List ( String, Value )
, decoder : () -> Decoder b
, description : () -> Dict String Description
, form : a -> List (Html b)
, partial : a -> b
, default : () -> b
}
object : b -> ObjectMeta a b
object ctor =
ObjectMeta
{ encoder = \_ -> []
, decoder = \_ -> JD.succeed ctor
, description = \_ -> Dict.empty
, form = \_ -> []
, partial = \_ -> ctor
, default = \_ -> ctor
}
field : String -> (a -> f) -> Meta f -> ObjectMeta a (f -> b) -> ObjectMeta a b
field name getter meta (ObjectMeta ometa) =
ObjectMeta
{ encoder = \v -> ( name, encoder meta <| getter v ) :: ometa.encoder v
, decoder = \_ -> JD.map2 (\f x -> f x) (ometa.decoder ()) (JD.field name (decoder meta))
, description = \_ -> Dict.insert name (description meta) (ometa.description ())
, form = Form.field name getter ometa.form ometa.partial (form meta)
, partial = \model -> ometa.partial model <| getter model
, default = \_ -> ometa.default () (default meta)
}
buildObject : ObjectMeta a a -> Meta a
buildObject (ObjectMeta { encoder, decoder, description, form, default }) =
Meta
{ encoder = \v -> JE.object <| encoder v
, decoder = decoder
, description = \_ -> Object <| description ()
, form = Form.object form
, default = default
}
--ADT
type AdtMeta cata fcata v
= AdtMeta
{ cata : cata
, decoder : String -> Decoder v -> Decoder v
, description : () -> Dict String (Array Description)
, fcata : fcata
, formOptions : Dict String (() -> v)
}
adt : cata -> fcata -> AdtMeta cata fcata v
adt cata fcata =
AdtMeta
{ cata = cata
, decoder = \_ -> identity
, description = \_ -> Dict.empty
, fcata = fcata
, formOptions = Dict.empty
}
{- alternative :
String
-> ((List ( String, Value ) -> Value) -> a)
-> ((List (Html v) -> Html v) -> b)
-> Decoder v
-> List Description
-> (() -> v)
-> AdtMeta (a -> c) (( String, b ) -> d) v
-> AdtMeta c d v
-}
alternative :
String
-> ((List ( String, Value ) -> Value) -> a)
-> ((List (Html v) -> ( String, Html v )) -> b)
-> Decoder v
-> List Description
-> (() -> v)
-> AdtMeta (a -> c) (b -> d) v
-> AdtMeta c d v
alternative name cataPiece formPiece decoderPiece descs default (AdtMeta { cata, fcata, decoder, description, formOptions }) =
let
enc v =
JE.object
[ ( "tag", JE.string name )
, ( "value", JE.object v )
]
form children =
( name, Html.div [] children )
decoder tag orElse =
if tag == name then
decoderPiece
else
decoder tag orElse
in
AdtMeta
{ cata = cata <| cataPiece enc
, decoder = decoder
, description = \_ -> Dict.insert name (Array.fromList descs) <| description ()
, fcata = fcata <| formPiece form
, formOptions = Dict.insert name default formOptions
}
alternative0 :
String
-> v
-> AdtMeta (Value -> b) (( String, Html v ) -> c) v
-> AdtMeta b c v
alternative0 name ctor =
alternative name
(\c -> c [])
(\c -> c [])
(JD.succeed ctor)
[]
(\_ -> ctor)
alternative1 :
String
-> (a -> v)
-> Meta a
-> AdtMeta ((a -> Value) -> b) ((a -> ( String, Html v )) -> c) v
-> AdtMeta b c v
alternative1 name ctor m1 =
alternative name
(\c v -> c [ ( "0", encoder m1 v ) ])
(\c v -> c [ Html.map ctor <| form m1 v ])
(JD.map ctor (JD.field "0" <| decoder m1))
[ description m1 ]
(\_ -> ctor <| default m1)
alternative2 :
String
-> (a -> b -> v)
-> Meta a
-> Meta b
-> AdtMeta ((a -> b -> Value) -> c) ((a -> b -> ( String, Html v )) -> d) v
-> AdtMeta c d v
alternative2 name ctor m1 m2 =
alternative name
(\c v1 v2 -> c [ ( "0", encoder m1 v1 ), ( "1", encoder m2 v2 ) ])
(\c v1 v2 ->
c
[ Html.map (\v1_ -> ctor v1_ v2) <| form m1 v1
, Html.map (\v2_ -> ctor v1 v2_) <| form m2 v2
]
)
(JD.map2 ctor (JD.field "0" <| decoder m1) (JD.field "1" <| decoder m2))
[ description m1, description m2 ]
(\_ -> ctor (default m1) (default m2))
buildAdt : (() -> a) -> AdtMeta (a -> Value) (a -> ( String, Html a )) a -> Meta a
buildAdt default (AdtMeta { cata, decoder, description, fcata, formOptions }) =
Meta
{ encoder = cata
, decoder =
\_ ->
JD.field "tag" JD.string
|> JD.andThen
(\tag ->
let
error =
"tag " ++ toString tag ++ "did not match"
in
JD.field "value" <| decoder tag <| JD.fail error
)
, description = \_ -> Adt <| description ()
, form = Form.adt formOptions fcata
, default = default
}
Pairs/Form.elm
module Pairs.Form
exposing
( adt
, array
, bool
, field
, float
, int
, object
, string
)
import Array exposing (Array)
import Dict exposing (Dict)
import Html as H exposing (Html)
import Html.Attributes as HA
import Html.Events as HE
type alias Form a =
a -> Html a
int : Form Int
int model =
H.input
[ HA.type_ "number"
, HE.onInput (String.toInt >> Result.withDefault model)
, HA.value <| toString model
]
[]
string : Form String
string model =
H.input
[ HA.type_ "text"
, HE.onInput identity
, HA.value model
]
[]
float : Form Float
float model =
H.input
[ HA.type_ "number"
, HE.onInput (String.toFloat >> Result.withDefault model)
, HA.value <| toString model
]
[]
bool : Form Bool
bool model =
H.input
[ HA.type_ "checkbox"
, HE.onCheck identity
, HA.checked model
]
[]
arrayRemove : Int -> Array a -> Array a
arrayRemove i a =
if i <= 0 then
Array.slice 1 (Array.length a) a
else if i >= (Array.length a - 1) then
Array.slice 0 (Array.length a - 1) a
else
Array.append (Array.slice 0 i a) (Array.slice i (Array.length a) a)
array : Form a -> a -> Form (Array a)
array form default model =
let
row i e =
H.li []
[ H.map (\e_ -> Array.set i e_ model) <| form e
, H.button
[ HE.onClick (arrayRemove i model) ]
[ H.text "Delete" ]
]
existing =
model
|> Array.toList
|> List.indexedMap row
add =
H.button
[ HE.onClick (Array.push default model) ]
[ H.text "Add new" ]
in
H.ul [] (existing ++ [ add ])
--field : a -> List (Html b)
field :
String
-> (a -> f)
-> (a -> List (Html (f -> b)))
-> (a -> f -> b)
-> (f -> Html f)
-> a
-> List (Html b)
field name getter oform partial form model =
let
init : List (Html b)
init =
oform model
|> List.map (H.map <| \b -> b (getter model))
label : Html x
label =
H.label [] [ H.text name ]
cell : Html b
cell =
H.map (partial model) <| form (getter model)
row : Html b
row =
H.tr []
[ H.td [] [ label ]
, H.td [] [ cell ]
]
in
init ++ [ row ]
object : (a -> List (Html a)) -> Form a
object form model =
H.table [] <| form model
adt : Dict String (() -> v) -> (v -> ( String, Html v )) -> Form v
adt options form model =
let
option name =
H.option
[ HA.value name, HA.selected <| name == selected ]
[ H.text name ]
( selected, inner ) =
form model
in
H.table []
[ H.tr []
[ H.td []
[ H.select
[ HE.onInput
(\n ->
case Dict.get n options of
Just def ->
def ()
Nothing ->
model
)
]
<|
List.map option (Dict.keys options)
]
]
, H.tr []
[ H.td []
[ inner
]
]
]