{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Boilerplate.Interpreter (interpretRule) where

import Boilerplate.Types
import Data.List (intersect)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import HsInspect.Types (Type(..))

data Ctx = G -- ^^ global context
         | P Text [(Maybe Text, Text, TyCtx)] -- ^^ product-like thing: cons [(maybe fieldname, param type, typarams)]
         | F Text Int (Maybe Text) Text TyCtx -- ^^ field in a product-like: cons idx fieldname param type typarams
         | T Text -- ^^ type parameter field
  deriving (Ctx -> Ctx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ctx -> Ctx -> Bool
$c/= :: Ctx -> Ctx -> Bool
== :: Ctx -> Ctx -> Bool
$c== :: Ctx -> Ctx -> Bool
Eq, Int -> Ctx -> ShowS
[Ctx] -> ShowS
Ctx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ctx] -> ShowS
$cshowList :: [Ctx] -> ShowS
show :: Ctx -> String
$cshow :: Ctx -> String
showsPrec :: Int -> Ctx -> ShowS
$cshowsPrec :: Int -> Ctx -> ShowS
Show)

data TyCtx = Poly | Higher | Concrete
  deriving (TyCtx -> TyCtx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TyCtx -> TyCtx -> Bool
$c/= :: TyCtx -> TyCtx -> Bool
== :: TyCtx -> TyCtx -> Bool
$c== :: TyCtx -> TyCtx -> Bool
Eq, Int -> TyCtx -> ShowS
[TyCtx] -> ShowS
TyCtx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TyCtx] -> ShowS
$cshowList :: [TyCtx] -> ShowS
show :: TyCtx -> String
$cshow :: TyCtx -> String
showsPrec :: Int -> TyCtx -> ShowS
$cshowsPrec :: Int -> TyCtx -> ShowS
Show)

interpretRule :: Rule -> Type -> Map Text Custom -> Either Text Text
interpretRule :: Rule -> Type -> Map Text Custom -> Either Text Text
interpretRule (Rule Tree
atoms) Type
tpe Map Text Custom
options = Text -> Text
T.strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ctx -> Tree -> Either Text Text
interpretTree Ctx
G Tree
atoms
  where
    interpretTree :: Ctx -> Tree -> Either Text Text
    interpretTree :: Ctx -> Tree -> Either Text Text
interpretTree Ctx
ctx Tree
t = [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Ctx -> Atom -> Either Text Text
interpret Ctx
ctx) Tree
t

    -- Several codepaths are impossible because of the way the Rule is parsed. We
    -- could have done some fancy type magic to avoid having to consider these
    -- cases, but it is far easier and simpler to just take the hit in the
    -- interpreter.
    impossible :: String -> a
    impossible :: forall a. String -> a
impossible String
ctx = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"impossible " forall a. Semigroup a => a -> a -> a
<> String
ctx

    showt :: Show a => a -> Text
    showt :: forall a. Show a => a -> Text
showt = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

    param :: Int -> Int -> Text
    param :: Int -> Int -> Text
param Int
n Int
p = Text
"p_" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
n forall a. Semigroup a => a -> a -> a
<> Text
"_" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
p

    tyCtx :: [Text] -> Text -> [Text] -> TyCtx
    tyCtx :: [Text] -> Text -> [Text] -> TyCtx
tyCtx [Text]
type_params Text
tpe [Text]
tpe_params =
      if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
tpe [Text]
type_params
      then TyCtx
Poly
      else if Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [a]
intersect [Text]
type_params [Text]
tpe_params
      then TyCtx
Higher
      else TyCtx
Concrete

    -- no context interpreter
    interpret :: Ctx -> Atom -> Either Text Text
interpret Ctx
ctx = \case
      Raw Text
txt -> forall a b. b -> Either a b
Right Text
txt
      Atom
Type -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ case Type
tpe of
        ProductType Text
tn [Text]
_ Bool
_ Text
_ [(Text, [Text])]
_ -> Text
tn
        RecordType Text
tn [Text]
_ Bool
_ Text
_ [(Text, Text, [Text])]
_ -> Text
tn
        SumType Text
tn [Text]
_ [(Text, [(Text, [Text])])]
_ -> Text
tn
      TParams Tree
empty Tree
prefix Tree
els Text
sep Text
suffix ->
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ctx]
tparams
        then Ctx -> Tree -> Either Text Text
interpretTree Ctx
G Tree
empty
        else (\Text
p Text
b -> Text
p forall a. Semigroup a => a -> a -> a
<> Text
b forall a. Semigroup a => a -> a -> a
<> Text
suffix) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ctx -> Tree -> Either Text Text
interpretTree Ctx
G Tree
prefix forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Text Text
body
        where
          tparams :: [Ctx]
tparams = Text -> Ctx
T forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
tpe of
            ProductType Text
_ [Text]
tps Bool
_ Text
_ [(Text, [Text])]
_ -> [Text]
tps
            RecordType Text
_ [Text]
tps Bool
_ Text
_ [(Text, Text, [Text])]
_ -> [Text]
tps
            SumType Text
_ [Text]
tps [(Text, [(Text, [Text])])]
_ -> [Text]
tps
          body :: Either Text Text
body = Text -> [Text] -> Text
T.intercalate Text
sep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ctx -> Tree -> Either Text Text
interpretTree Tree
els) [Ctx]
tparams
      Atom
TParam -> case Ctx
ctx of
        T Text
p -> forall a b. b -> Either a b
Right Text
p
        Ctx
_ -> forall a. String -> a
impossible String
"TParam"
      Product Tree
els ->
        let interpret' :: Text -> [(Maybe Text, Text, TyCtx)] -> Either Text Text
interpret' Text
c [(Maybe Text, Text, TyCtx)]
ps = Ctx -> Tree -> Either Text Text
interpretTree (Text -> [(Maybe Text, Text, TyCtx)] -> Ctx
P Text
c [(Maybe Text, Text, TyCtx)]
ps) Tree
els
         in case Type
tpe of
        SumType Text
_ [Text]
_ [(Text, [(Text, [Text])])]
_ -> forall a b. b -> Either a b
Right Text
T.empty
        ProductType Text
_ [Text]
tps Bool
_ Text
cons [(Text, [Text])]
params -> Text -> [(Maybe Text, Text, TyCtx)] -> Either Text Text
interpret' Text
cons forall a b. (a -> b) -> a -> b
$ (\(Text
tpe, [Text]
tys) -> (forall a. Maybe a
Nothing, Text
tpe, [Text] -> Text -> [Text] -> TyCtx
tyCtx [Text]
tps Text
tpe [Text]
tys)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, [Text])]
params
        RecordType Text
_ [Text]
tps Bool
_ Text
cons [(Text, Text, [Text])]
params -> Text -> [(Maybe Text, Text, TyCtx)] -> Either Text Text
interpret' Text
cons forall a b. (a -> b) -> a -> b
$ (\(Text
nme, Text
tpe, [Text]
tys) -> (forall a. a -> Maybe a
Just Text
nme, Text
tpe, [Text] -> Text -> [Text] -> TyCtx
tyCtx [Text]
tps Text
tpe [Text]
tys)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text, [Text])]
params
      Sum Text
prefix Tree
els Text
sep Text
suffix -> case Type
tpe of
        ProductType Text
_ [Text]
_ Bool
_ Text
_ [(Text, [Text])]
_ -> forall a b. b -> Either a b
Right Text
T.empty
        RecordType Text
_ [Text]
_ Bool
_ Text
_ [(Text, Text, [Text])]
_ -> forall a b. b -> Either a b
Right Text
T.empty
        SumType Text
_ [Text]
tps [(Text, [(Text, [Text])])]
tags -> (\Text
b -> Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
b forall a. Semigroup a => a -> a -> a
<> Text
suffix) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Text
body
          where
            tags' :: [Ctx]
tags' = (\(Text
cons, [(Text, [Text])]
tpes) -> Text -> [(Maybe Text, Text, TyCtx)] -> Ctx
P Text
cons ((\(Text
tpe, [Text]
tys) -> (forall a. Maybe a
Nothing, Text
tpe, [Text] -> Text -> [Text] -> TyCtx
tyCtx [Text]
tps Text
tpe [Text]
tys)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, [Text])]
tpes)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, [(Text, [Text])])]
tags
            body :: Either Text Text
body = Text -> [Text] -> Text
T.intercalate Text
sep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ctx -> Tree -> Either Text Text
interpretTree Tree
els) [Ctx]
tags'
      Uncons Int
n -> case Ctx
ctx of
        P Text
cons [] -> forall a b. b -> Either a b
Right Text
cons
        P Text
cons [(Maybe Text, Text, TyCtx)]
ps -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
body forall a. Semigroup a => a -> a -> a
<> Text
")"
          where
            body :: Text
body = Text -> [Text] -> Text
T.intercalate Text
" " forall a b. (a -> b) -> a -> b
$ Text
cons forall a. a -> [a] -> [a]
: ((Int -> Int -> Text
param Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [(Maybe Text, Text, TyCtx)]
ps)
        Ctx
_ -> forall a. String -> a
impossible String
"Uncons"
      Atom
Cons -> case Ctx
ctx of
        P Text
cons [(Maybe Text, Text, TyCtx)]
_ -> forall a b. b -> Either a b
Right Text
cons
        F Text
cons Int
_ Maybe Text
_ Text
_ TyCtx
_ -> forall a b. b -> Either a b
Right Text
cons
        Ctx
_ -> forall a. String -> a
impossible String
"Cons"
      Field Tree
empty Tree
prefix Tree
els Text
sep Text
suffix -> case Ctx
ctx of
        P Text
_ [] -> Ctx -> Tree -> Either Text Text
interpretTree Ctx
ctx Tree
empty
        P Text
cons [(Maybe Text, Text, TyCtx)]
ps -> (\Text
p Text
b -> Text
p forall a. Semigroup a => a -> a -> a
<> Text
b forall a. Semigroup a => a -> a -> a
<> Text
suffix) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ctx -> Tree -> Either Text Text
interpretTree Ctx
ctx Tree
prefix forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Text Text
body
          where
            fields :: [Ctx]
fields = (\(Int
n, (Maybe Text
f, Text
t, TyCtx
tc)) -> Text -> Int -> Maybe Text -> Text -> TyCtx -> Ctx
F Text
cons Int
n Maybe Text
f Text
t TyCtx
tc) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [(Maybe Text, Text, TyCtx)]
ps
            body :: Either Text Text
body = Text -> [Text] -> Text
T.intercalate Text
sep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> b -> a -> c
flip Ctx -> Tree -> Either Text Text
interpretTree Tree
els) [Ctx]
fields
        Ctx
_ -> forall a. String -> a
impossible String
"Field"
      Param Int
n ->  case Ctx
ctx of
        F Text
_ Int
p Maybe Text
_ Text
_ TyCtx
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int -> Int -> Text
param Int
n Int
p
        Ctx
_ -> forall a. String -> a
impossible String
"Param"
      Atom
FieldName -> case Ctx
ctx of
        F Text
_ Int
_ Maybe Text
n Text
_ TyCtx
_ -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Text
"field names are required") forall a b. b -> Either a b
Right Maybe Text
n
        Ctx
_ -> forall a. String -> a
impossible String
"FieldName"
      Atom
FieldType -> case Ctx
ctx of
        F Text
_ Int
_ Maybe Text
_ Text
t TyCtx
_ -> forall a b. b -> Either a b
Right Text
t
        Ctx
_ -> forall a. String -> a
impossible String
"FieldType"
      TyCase Tree
poly Tree
higher Tree
concrete -> case Ctx
ctx of
        F Text
_ Int
_ Maybe Text
_ Text
_ TyCtx
ty -> Ctx -> Tree -> Either Text Text
interpretTree Ctx
ctx forall a b. (a -> b) -> a -> b
$ case TyCtx
ty of
          TyCtx
Poly -> Tree
poly
          TyCtx
Higher -> Tree
higher
          TyCtx
Concrete -> Tree
concrete
        Ctx
_ -> forall a. String -> a
impossible String
"TyCase"
      Custom Text
sym Maybe Tree
fallback ->
        let err :: Either Text b
err = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"missing required option '" forall a. Semigroup a => a -> a -> a
<> Text
sym forall a. Semigroup a => a -> a -> a
<> Text
"' which should be " forall a. Semigroup a => a -> a -> a
<> Text
ctx'
            ctx' :: Text
ctx' = case Ctx
ctx of
              Ctx
G -> Text
"a global value"
              T Text
_ -> Text
"a global value"
              P Text
cons [(Maybe Text, Text, TyCtx)]
_ -> Text
"a mapping for the data constructors of " forall a. Semigroup a => a -> a -> a
<> Text
cons
              F Text
cons Int
_ Maybe Text
_ Text
_ TyCtx
_ -> Text
"an indexed sequence for fields of the data constructor " forall a. Semigroup a => a -> a -> a
<> Text
cons
         in case (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
sym Map Text Custom
options, Ctx
ctx) of
          (Just (Global Text
txt), Ctx
_) -> forall a b. b -> Either a b
Right Text
txt
          (Just (Indexed [Text]
vs), F Text
_ Int
p Maybe Text
_ Text
_ TyCtx
_) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {b}. Either Text b
err forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> Maybe a
atMay (Int
p forall a. Num a => a -> a -> a
- Int
1) [Text]
vs
          (Just (Named Map Text Text
vs), F Text
_ Int
_ (Just Text
f) Text
_ TyCtx
_) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {b}. Either Text b
err forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
f Map Text Text
vs
          (Just (NamedIndexed Map Text [Text]
vs), F Text
cons Int
p Maybe Text
_ Text
_ TyCtx
_) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {b}. Either Text b
err forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> Maybe a
atMay (Int
p forall a. Num a => a -> a -> a
- Int
1) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
cons Map Text [Text]
vs
          (Just (Named Map Text Text
vs), P Text
cons [(Maybe Text, Text, TyCtx)]
_) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {b}. Either Text b
err forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
cons Map Text Text
vs
          (Maybe Custom, Ctx)
_ -> case Maybe Tree
fallback of
            Maybe Tree
Nothing -> forall {b}. Either Text b
err
            Just Tree
t -> Ctx -> Tree -> Either Text Text
interpretTree Ctx
ctx Tree
t
      Sugar Sugar
sugar -> Ctx -> Tree -> Either Text Text
interpretTree Ctx
ctx forall a b. (a -> b) -> a -> b
$ case Sugar
sugar of
        Instance Text
tc ->
          [Text -> Atom
Raw Text
"instance ",
           Tree -> Tree -> Tree -> Text -> Text -> Atom
TParams [] [Text -> Atom
Raw Text
"("] [Text -> Atom
Raw Text
tc, Text -> Atom
Raw Text
" ", Atom
TParam] Text
", " Text
") => ", Text -> Atom
Raw Text
tc, Text -> Atom
Raw Text
" ",
           Tree -> Tree -> Tree -> Text -> Text -> Atom
TParams [Atom
Type] [Text -> Atom
Raw Text
"(", Atom
Type, Text -> Atom
Raw Text
" "] [Atom
TParam] Text
" " Text
")", Text -> Atom
Raw Text
" where"]
        Data Tree
tree ->
          [Tree -> Atom
Product Tree
tree, Text -> Tree -> Text -> Text -> Atom
Sum Text
"" Tree
tree Text
"" Text
""]

atMay :: Int -> [a] -> Maybe a
atMay :: forall a. Int -> [a] -> Maybe a
atMay Int
i [a]
as | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Maybe a
Nothing
        | Bool
otherwise = forall {t} {a}. (Eq t, Num t) => t -> [a] -> Maybe a
f Int
i [a]
as
    where f :: t -> [a] -> Maybe a
f t
0 (a
x : [a]
_) = forall a. a -> Maybe a
Just a
x
          f t
i' (a
_ : [a]
as') = t -> [a] -> Maybe a
f (t
i' forall a. Num a => a -> a -> a
- t
1) [a]
as'
          f t
_ [] = forall a. Maybe a
Nothing