{-# 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
| P Text [(Maybe Text, Text, TyCtx)]
| F Text Int (Maybe Text) Text TyCtx
| T Text
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
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
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