module Text.EDE.Internal.Types where
import Control.Applicative
import Control.Comonad
import Control.Comonad.Cofree
import Control.Lens
import Data.Aeson.Types hiding (Result(..))
import Data.Foldable
import Data.HashMap.Strict (HashMap)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import Data.Monoid hiding ((<>))
import Data.Semigroup
import Data.Text (Text)
import qualified Data.Text as Text
import Text.PrettyPrint.ANSI.Leijen (Pretty(..), Doc)
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import Text.Trifecta.Delta
newtype PP a = PP { unPP :: a }
pp :: Pretty (PP a) => a -> Doc
pp = pretty . PP
instance Pretty (PP Text) where
pretty = PP.string . Text.unpack . unPP
instance Pretty (PP Value) where
pretty (PP v) =
case v of
Null -> "Null"
Bool _ -> "Bool"
Number _ -> "Scientific"
Object _ -> "Object"
Array _ -> "Array"
String _ -> "String"
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 (PP.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 (PP.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
type Delim = (String, String)
data Syntax = Syntax
{ _delimPragma :: !Delim
, _delimInline :: !Delim
, _delimComment :: !Delim
, _delimBlock :: !Delim
}
makeClassy ''Syntax
type Resolver m = Syntax -> Id -> 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 Delta)
, _tmplIncl :: HashMap Id (Exp Delta)
} deriving (Eq)
type Id = Text
newtype Var = Var (NonEmpty Id)
deriving (Eq)
instance Pretty Var where
pretty (Var is) = PP.hcat
. PP.punctuate "."
. map (PP.bold . pp)
$ NonEmpty.toList is
instance Show Var where
show = show . pretty
data Collection where
Col :: Foldable f => Int -> f (Maybe Text, Value) -> Collection
data Pat
= PWild
| PVar !Var
| PLit !Value
deriving (Eq, Show)
type Alt a = (Pat, a)
data ExpF a
= ELit !Value
| EVar !Var
| EFun !Id
| EApp !a !a
| ELet !Id !a !a
| ECase !a [Alt a]
| ELoop !Id !a !a
| EIncl !Text
deriving (Eq, Show, Functor)
type Exp = Cofree ExpF
instance HasDelta (Exp Delta) where
delta = extract
fromValue :: Value -> Maybe Object
fromValue (Object o) = Just o
fromValue _ = Nothing
fromPairs :: [Pair] -> Object
fromPairs = (\(Object o) -> o) . object