{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language DeriveFunctor #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeOperators #-}
module Language.Haskell.To.Elm.DataShape where

import Generics.SOP

type DataShape a = [(String, ConstructorShape a)]

data ConstructorShape a
  = ConstructorShape [a]
  | RecordConstructorShape [(String, a)]
  deriving a -> ConstructorShape b -> ConstructorShape a
(a -> b) -> ConstructorShape a -> ConstructorShape b
(forall a b. (a -> b) -> ConstructorShape a -> ConstructorShape b)
-> (forall a b. a -> ConstructorShape b -> ConstructorShape a)
-> Functor ConstructorShape
forall a b. a -> ConstructorShape b -> ConstructorShape a
forall a b. (a -> b) -> ConstructorShape a -> ConstructorShape b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ConstructorShape b -> ConstructorShape a
$c<$ :: forall a b. a -> ConstructorShape b -> ConstructorShape a
fmap :: (a -> b) -> ConstructorShape a -> ConstructorShape b
$cfmap :: forall a b. (a -> b) -> ConstructorShape a -> ConstructorShape b
Functor

nullary :: ConstructorShape a -> Bool
nullary :: ConstructorShape a -> Bool
nullary (ConstructorShape []) = Bool
True
nullary ConstructorShape a
_ = Bool
False

data Dict constraint where
  Dict :: constraint => Dict constraint

newtype ConstraintFun constraint a = ConstraintFun (forall t. Dict (constraint t) -> a)

dataShape
  :: forall typ constraint a
  . (All2 constraint (Code typ), HasDatatypeInfo typ)
  => ConstraintFun constraint a
  -> DataShape a
dataShape :: ConstraintFun constraint a -> DataShape a
dataShape ConstraintFun constraint a
f =
  ConstraintFun constraint a
-> NP ConstructorInfo (Code typ) -> DataShape a
forall (constrs :: [[*]]) (constraint :: * -> Constraint) a.
All2 constraint constrs =>
ConstraintFun constraint a
-> NP ConstructorInfo constrs -> [(String, ConstructorShape a)]
constructorShapes @(Code typ) @constraint ConstraintFun constraint a
f (NP ConstructorInfo (Code typ) -> DataShape a)
-> NP ConstructorInfo (Code typ) -> DataShape a
forall a b. (a -> b) -> a -> b
$ DatatypeInfo (Code typ) -> NP ConstructorInfo (Code typ)
forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
constructorInfo (DatatypeInfo (Code typ) -> NP ConstructorInfo (Code typ))
-> DatatypeInfo (Code typ) -> NP ConstructorInfo (Code typ)
forall a b. (a -> b) -> a -> b
$ Proxy typ -> DatatypeInfo (Code typ)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo (Proxy typ -> DatatypeInfo (Code typ))
-> Proxy typ -> DatatypeInfo (Code typ)
forall a b. (a -> b) -> a -> b
$ Proxy typ
forall k (t :: k). Proxy t
Proxy @typ

constructorShapes
  :: forall constrs constraint a
  . All2 constraint constrs
  => ConstraintFun constraint a
  -> NP ConstructorInfo constrs
  -> [(String, ConstructorShape a)]
constructorShapes :: ConstraintFun constraint a
-> NP ConstructorInfo constrs -> [(String, ConstructorShape a)]
constructorShapes ConstraintFun constraint a
f NP ConstructorInfo constrs
infos =
  case NP ConstructorInfo constrs
infos of
    NP ConstructorInfo constrs
Nil ->
      []

    ConstructorInfo x
info :* NP ConstructorInfo xs
infos' ->
      ConstraintFun constraint a
-> ConstructorInfo x -> (String, ConstructorShape a)
forall (constr :: [*]) (constraint :: * -> Constraint) a.
All constraint constr =>
ConstraintFun constraint a
-> ConstructorInfo constr -> (String, ConstructorShape a)
constructorShape ConstraintFun constraint a
f ConstructorInfo x
info (String, ConstructorShape a)
-> [(String, ConstructorShape a)] -> [(String, ConstructorShape a)]
forall a. a -> [a] -> [a]
: ConstraintFun constraint a
-> NP ConstructorInfo xs -> [(String, ConstructorShape a)]
forall (constrs :: [[*]]) (constraint :: * -> Constraint) a.
All2 constraint constrs =>
ConstraintFun constraint a
-> NP ConstructorInfo constrs -> [(String, ConstructorShape a)]
constructorShapes ConstraintFun constraint a
f NP ConstructorInfo xs
infos'

constructorShape
  :: forall constr constraint a
  . All constraint constr
  => ConstraintFun constraint a
  -> ConstructorInfo constr
  -> (String, ConstructorShape a)
constructorShape :: ConstraintFun constraint a
-> ConstructorInfo constr -> (String, ConstructorShape a)
constructorShape ConstraintFun constraint a
f ConstructorInfo constr
info =
  case ConstructorInfo constr
info of
    Constructor String
cname ->
      (String
cname, [a] -> ConstructorShape a
forall a. [a] -> ConstructorShape a
ConstructorShape ([a] -> ConstructorShape a) -> [a] -> ConstructorShape a
forall a b. (a -> b) -> a -> b
$ ConstraintFun constraint a -> Shape constr -> [a]
forall (constraint :: * -> Constraint) (fields :: [*]) a.
All constraint fields =>
ConstraintFun constraint a -> Shape fields -> [a]
constructorFieldShape ConstraintFun constraint a
f (Shape constr -> [a]) -> Shape constr -> [a]
forall a b. (a -> b) -> a -> b
$ SListI constr => Shape constr
forall k (xs :: [k]). SListI xs => Shape xs
shape @_ @constr)

    Infix {} ->
      String -> (String, ConstructorShape a)
forall a. HasCallStack => String -> a
error String
"Infix constructors are not supported"

    Record String
cname NP FieldInfo constr
fs ->
      (String
cname, [(String, a)] -> ConstructorShape a
forall a. [(String, a)] -> ConstructorShape a
RecordConstructorShape ([(String, a)] -> ConstructorShape a)
-> [(String, a)] -> ConstructorShape a
forall a b. (a -> b) -> a -> b
$ ConstraintFun constraint a -> NP FieldInfo constr -> [(String, a)]
forall (fields :: [*]) (constraint :: * -> Constraint) a.
All constraint fields =>
ConstraintFun constraint a -> NP FieldInfo fields -> [(String, a)]
recordFieldShape ConstraintFun constraint a
f NP FieldInfo constr
fs)

constructorFieldShape
  :: All constraint fields
  => ConstraintFun constraint a
  -> Shape fields
  -> [a]
constructorFieldShape :: ConstraintFun constraint a -> Shape fields -> [a]
constructorFieldShape ConstraintFun constraint a
f Shape fields
shape_ =
  case Shape fields
shape_ of
    Shape fields
ShapeNil ->
      []

    s :: Shape fields
s@(ShapeCons Shape xs
_) -> ConstraintFun constraint a -> Shape (x : xs) -> [a]
forall field (fields :: [*]) (constraint :: * -> Constraint) a.
(constraint field, All constraint fields) =>
ConstraintFun constraint a -> Shape (field : fields) -> [a]
go ConstraintFun constraint a
f Shape fields
Shape (x : xs)
s
      where
        go
          :: forall field fields constraint a
          . (constraint field, All constraint fields)
          => ConstraintFun constraint a
          -> Shape (field ': fields)
          -> [a]
        go :: ConstraintFun constraint a -> Shape (field : fields) -> [a]
go f' :: ConstraintFun constraint a
f'@(ConstraintFun forall t. Dict (constraint t) -> a
fun) (ShapeCons Shape xs
s') = Dict (constraint field) -> a
forall t. Dict (constraint t) -> a
fun @field Dict (constraint field)
forall (constraint :: Constraint). constraint => Dict constraint
Dict a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ConstraintFun constraint a -> Shape xs -> [a]
forall (constraint :: * -> Constraint) (fields :: [*]) a.
All constraint fields =>
ConstraintFun constraint a -> Shape fields -> [a]
constructorFieldShape ConstraintFun constraint a
f' Shape xs
s'

recordFieldShape
  :: forall fields constraint a
  . All constraint fields
  => ConstraintFun constraint a
  -> NP FieldInfo fields
  -> [(String, a)]
recordFieldShape :: ConstraintFun constraint a -> NP FieldInfo fields -> [(String, a)]
recordFieldShape ConstraintFun constraint a
f NP FieldInfo fields
infos =
  case NP FieldInfo fields
infos of
    NP FieldInfo fields
Nil ->
      []

    FieldInfo x
info :* NP FieldInfo xs
infos' ->
      ConstraintFun constraint a -> FieldInfo x -> (String, a)
forall field.
constraint field =>
ConstraintFun constraint a -> FieldInfo field -> (String, a)
go ConstraintFun constraint a
f FieldInfo x
info (String, a) -> [(String, a)] -> [(String, a)]
forall a. a -> [a] -> [a]
: ConstraintFun constraint a -> NP FieldInfo xs -> [(String, a)]
forall (fields :: [*]) (constraint :: * -> Constraint) a.
All constraint fields =>
ConstraintFun constraint a -> NP FieldInfo fields -> [(String, a)]
recordFieldShape ConstraintFun constraint a
f NP FieldInfo xs
infos'

      where
        go
          :: forall field
          . constraint field
          => ConstraintFun constraint a
          -> FieldInfo field
          -> (String, a)
        go :: ConstraintFun constraint a -> FieldInfo field -> (String, a)
go (ConstraintFun forall t. Dict (constraint t) -> a
fun) (FieldInfo String
fname) =
          (String
fname, Dict (constraint field) -> a
forall t. Dict (constraint t) -> a
fun @field Dict (constraint field)
forall (constraint :: Constraint). constraint => Dict constraint
Dict)