module Text.EDE.Internal.Types where
import Control.Applicative
import Control.Lens
import Data.Aeson.Types hiding (Result(..))
import Data.Foldable
import Data.HashMap.Strict (HashMap)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Monoid hiding ((<>))
import Data.Maybe
import Data.Semigroup
import Data.Text (Text)
import Data.Text.Format (Format, format)
import Data.Text.Format.Params (Params)
import qualified Data.Text.Lazy as LText
import Text.PrettyPrint.ANSI.Leijen (Pretty(..), Doc, vsep)
import Text.Trifecta.Delta
data Result a
= Success a
| Failure Doc
deriving (Show, Functor, Foldable, Traversable)
makePrisms ''Result
instance Monad Result where
return = Success
Success x >>= k = k x
Failure e >>= _ = Failure e
instance Applicative Result where
pure = return
Success f <*> Success x = Success (f x)
Success _ <*> Failure e = Failure e
Failure e <*> Success _ = Failure e
Failure e <*> Failure e' = Failure (vsep [e, e'])
instance Alternative Result where
Success x <|> Success _ = Success x
Success x <|> Failure _ = Success x
Failure _ <|> Success x = Success x
Failure e <|> Failure e' = Failure (vsep [e, e'])
empty = Failure mempty
instance Show a => Pretty (Result a) where
pretty (Success x) = pretty (show x)
pretty (Failure e) = pretty e
eitherResult :: Result a -> Either String a
eitherResult = result (Left . show) Right
result :: (Doc -> b)
-> (a -> b)
-> Result a
-> b
result _ g (Success x) = g x
result f _ (Failure e) = f e
success :: Monad m => a -> m (Result a)
success = return . Success
failure :: Monad m => Doc -> m (Result a)
failure = return . Failure
throwError :: Params ps => Format -> ps -> Result a
throwError fmt = Failure . pretty . LText.unpack . format fmt
type Delim = (String, String)
data Syntax = Syntax
{ _delimPragma :: !Delim
, _delimInline :: !Delim
, _delimComment :: !Delim
, _delimBlock :: !Delim
}
makeClassy ''Syntax
type Resolver m = Syntax -> Text -> Delta -> m (Result Template)
instance Applicative m => Semigroup (Resolver m) where
(f <> g) o k d = liftA2 (<|>) (f o k d) (g o k d)
data Template = Template
{ _tmplName :: !Text
, _tmplExp :: !Exp
, _tmplIncl :: HashMap Text Exp
} deriving (Eq)
type Id = Text
newtype Var = Var (NonEmpty Id)
deriving (Eq, Show)
data Collection where
Col :: Foldable f => Int -> f (Maybe Text, Value) -> Collection
data Pat
= PWild
| PVar !Var
| PLit !Value
deriving (Eq, Show)
type Alt = (Pat, Exp)
data Exp
= ELit !Delta !Value
| EVar !Delta !Var
| EFun !Delta !Id
| EApp !Delta !Exp !Exp
| ELet !Delta !Id !Exp !Exp
| ECase !Delta !Exp [Alt]
| ELoop !Delta !Id !Exp !Exp
| EIncl !Delta !Text
deriving (Eq, Show)
instance HasDelta Exp where
delta = \case
ELit d _ -> d
EVar d _ -> d
EFun d _ -> d
EApp d _ _ -> d
ELet d _ _ _ -> d
ECase d _ _ -> d
ELoop d _ _ _ -> d
EIncl d _ -> d
var :: Id -> Var
var = Var . (:| [])
eapp :: Delta -> [Exp] -> Exp
eapp d [] = ELit d (String mempty)
eapp _ [e] = e
eapp d (e:es) = foldl' (EApp d) e es
efun :: Delta -> Id -> Exp -> Exp
efun d = EApp d . EFun d
elet :: Delta -> Exp -> Maybe (Id, Exp) -> Exp
elet d e = \case
Nothing -> e
Just (i, b) -> ELet d i b e
ecase :: Exp -> [Alt] -> Maybe Exp -> Exp
ecase p ws f = ECase (delta p) p (ws ++ maybe [] ((:[]) . wild) f)
eif :: (Exp, Exp) -> [(Exp, Exp)] -> Maybe Exp -> Exp
eif t@(x, _) ts f = foldr' c (fromMaybe (bld (delta x)) f) (t:ts)
where
c (p, w) e = ECase (delta p) p [true w, false e]
eempty :: Delta -> Exp -> Exp -> Maybe Exp -> Exp
eempty d v e = maybe e (eif (efun d "!" (efun d "empty" v), e) [] . Just)
wild, true, false :: Exp -> Alt
wild = (PWild,)
true = (PLit (Bool True),)
false = (PLit (Bool False),)
bld :: Delta -> Exp
bld = (`ELit` String mempty)
fromValue :: Value -> Maybe Object
fromValue (Object o) = Just o
fromValue _ = Nothing
fromPairs :: [Pair] -> Object
fromPairs = (\(Object o) -> o) . object