{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Untyped representation of abstract syntax trees
module Dino.AST
  ( -- * Representation
    Field (..)
  , Mapping (..)
  , NameType (..)
  , Constr (..)
  , Importance (..)
  , AST (..)
  , record
  , prettyNamed

    -- * Generic inspection
  , GInspectableArgs (..)
  , GInspectableFields (..)
  , GInspectable (..)
  , Inspectable (..)
  , inspectListAsRec

    -- * Conversion to Tree
  , toTree
  , showTree
  , drawTree
  , htmlTree
  ) where

import Prelude

import Data.Hashable (Hashable (..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Proxy (Proxy (..))
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Tree (Tree(..))
import Data.Tree.View (Behavior(..), NodeInfo(..))
import qualified Data.Tree.View as View
import GHC.Generics
  ( (:+:)(..)
  , (:*:)(..)
  , C1
  , D1
  , Generic(..)
  , K1(..)
  , M1(..)
  , Meta(..)
  , Rec0
  , Rep
  , S1
  , U1
  )
import GHC.Stack (HasCallStack)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..))
import qualified Text.PrettyPrint.ANSI.Leijen as PP

import Dino.Pretty



--------------------------------------------------------------------------------
-- * Representation
--------------------------------------------------------------------------------

-- A key-value mapping, used to represent records
--
-- The 'Importance' argument to 'Mapping' is used to distinguish between records
-- whose fields are essentially named parameters and records whose fields carry
-- information.
--
-- For example, a collection of people could be represented as a nested record
-- like this:
--
-- > { Harry = {age = 45, speed = 46}
-- > , Harriet = {age = 47, speed = 48}
-- > , ...
-- > }
--
-- In this case, the outer record can be considered to have 'Important' fields,
-- while the fields in the inner records are just there to give meaning to the
-- numbers.
--
-- But why not just add a @name@ field to the inner records and represent the
-- above collection as a list? The reason why a nested record may be preferred
-- is that it puts the name on the path from the root, which means that it will
-- show up in diffs.
data Mapping k v = Mapping Importance !(HashMap k v)
  deriving (Mapping k v -> Mapping k v -> Bool
(Mapping k v -> Mapping k v -> Bool)
-> (Mapping k v -> Mapping k v -> Bool) -> Eq (Mapping k v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k v. (Eq k, Eq v) => Mapping k v -> Mapping k v -> Bool
/= :: Mapping k v -> Mapping k v -> Bool
$c/= :: forall k v. (Eq k, Eq v) => Mapping k v -> Mapping k v -> Bool
== :: Mapping k v -> Mapping k v -> Bool
$c== :: forall k v. (Eq k, Eq v) => Mapping k v -> Mapping k v -> Bool
Eq, Int -> Mapping k v -> ShowS
[Mapping k v] -> ShowS
Mapping k v -> String
(Int -> Mapping k v -> ShowS)
-> (Mapping k v -> String)
-> ([Mapping k v] -> ShowS)
-> Show (Mapping k v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> Mapping k v -> ShowS
forall k v. (Show k, Show v) => [Mapping k v] -> ShowS
forall k v. (Show k, Show v) => Mapping k v -> String
showList :: [Mapping k v] -> ShowS
$cshowList :: forall k v. (Show k, Show v) => [Mapping k v] -> ShowS
show :: Mapping k v -> String
$cshow :: forall k v. (Show k, Show v) => Mapping k v -> String
showsPrec :: Int -> Mapping k v -> ShowS
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> Mapping k v -> ShowS
Show, Mapping k a -> Bool
(a -> m) -> Mapping k a -> m
(a -> b -> b) -> b -> Mapping k a -> b
(forall m. Monoid m => Mapping k m -> m)
-> (forall m a. Monoid m => (a -> m) -> Mapping k a -> m)
-> (forall m a. Monoid m => (a -> m) -> Mapping k a -> m)
-> (forall a b. (a -> b -> b) -> b -> Mapping k a -> b)
-> (forall a b. (a -> b -> b) -> b -> Mapping k a -> b)
-> (forall b a. (b -> a -> b) -> b -> Mapping k a -> b)
-> (forall b a. (b -> a -> b) -> b -> Mapping k a -> b)
-> (forall a. (a -> a -> a) -> Mapping k a -> a)
-> (forall a. (a -> a -> a) -> Mapping k a -> a)
-> (forall a. Mapping k a -> [a])
-> (forall a. Mapping k a -> Bool)
-> (forall a. Mapping k a -> Int)
-> (forall a. Eq a => a -> Mapping k a -> Bool)
-> (forall a. Ord a => Mapping k a -> a)
-> (forall a. Ord a => Mapping k a -> a)
-> (forall a. Num a => Mapping k a -> a)
-> (forall a. Num a => Mapping k a -> a)
-> Foldable (Mapping k)
forall a. Eq a => a -> Mapping k a -> Bool
forall a. Num a => Mapping k a -> a
forall a. Ord a => Mapping k a -> a
forall m. Monoid m => Mapping k m -> m
forall a. Mapping k a -> Bool
forall a. Mapping k a -> Int
forall a. Mapping k a -> [a]
forall a. (a -> a -> a) -> Mapping k a -> a
forall k a. Eq a => a -> Mapping k a -> Bool
forall k a. Num a => Mapping k a -> a
forall k a. Ord a => Mapping k a -> a
forall m a. Monoid m => (a -> m) -> Mapping k a -> m
forall k m. Monoid m => Mapping k m -> m
forall k a. Mapping k a -> Bool
forall k a. Mapping k a -> Int
forall k a. Mapping k a -> [a]
forall b a. (b -> a -> b) -> b -> Mapping k a -> b
forall a b. (a -> b -> b) -> b -> Mapping k a -> b
forall k a. (a -> a -> a) -> Mapping k a -> a
forall k m a. Monoid m => (a -> m) -> Mapping k a -> m
forall k b a. (b -> a -> b) -> b -> Mapping k a -> b
forall k a b. (a -> b -> b) -> b -> Mapping k a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: Mapping k a -> a
$cproduct :: forall k a. Num a => Mapping k a -> a
sum :: Mapping k a -> a
$csum :: forall k a. Num a => Mapping k a -> a
minimum :: Mapping k a -> a
$cminimum :: forall k a. Ord a => Mapping k a -> a
maximum :: Mapping k a -> a
$cmaximum :: forall k a. Ord a => Mapping k a -> a
elem :: a -> Mapping k a -> Bool
$celem :: forall k a. Eq a => a -> Mapping k a -> Bool
length :: Mapping k a -> Int
$clength :: forall k a. Mapping k a -> Int
null :: Mapping k a -> Bool
$cnull :: forall k a. Mapping k a -> Bool
toList :: Mapping k a -> [a]
$ctoList :: forall k a. Mapping k a -> [a]
foldl1 :: (a -> a -> a) -> Mapping k a -> a
$cfoldl1 :: forall k a. (a -> a -> a) -> Mapping k a -> a
foldr1 :: (a -> a -> a) -> Mapping k a -> a
$cfoldr1 :: forall k a. (a -> a -> a) -> Mapping k a -> a
foldl' :: (b -> a -> b) -> b -> Mapping k a -> b
$cfoldl' :: forall k b a. (b -> a -> b) -> b -> Mapping k a -> b
foldl :: (b -> a -> b) -> b -> Mapping k a -> b
$cfoldl :: forall k b a. (b -> a -> b) -> b -> Mapping k a -> b
foldr' :: (a -> b -> b) -> b -> Mapping k a -> b
$cfoldr' :: forall k a b. (a -> b -> b) -> b -> Mapping k a -> b
foldr :: (a -> b -> b) -> b -> Mapping k a -> b
$cfoldr :: forall k a b. (a -> b -> b) -> b -> Mapping k a -> b
foldMap' :: (a -> m) -> Mapping k a -> m
$cfoldMap' :: forall k m a. Monoid m => (a -> m) -> Mapping k a -> m
foldMap :: (a -> m) -> Mapping k a -> m
$cfoldMap :: forall k m a. Monoid m => (a -> m) -> Mapping k a -> m
fold :: Mapping k m -> m
$cfold :: forall k m. Monoid m => Mapping k m -> m
Foldable, a -> Mapping k b -> Mapping k a
(a -> b) -> Mapping k a -> Mapping k b
(forall a b. (a -> b) -> Mapping k a -> Mapping k b)
-> (forall a b. a -> Mapping k b -> Mapping k a)
-> Functor (Mapping k)
forall a b. a -> Mapping k b -> Mapping k a
forall a b. (a -> b) -> Mapping k a -> Mapping k b
forall k a b. a -> Mapping k b -> Mapping k a
forall k a b. (a -> b) -> Mapping k a -> Mapping k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Mapping k b -> Mapping k a
$c<$ :: forall k a b. a -> Mapping k b -> Mapping k a
fmap :: (a -> b) -> Mapping k a -> Mapping k b
$cfmap :: forall k a b. (a -> b) -> Mapping k a -> Mapping k b
Functor, Functor (Mapping k)
Foldable (Mapping k)
Functor (Mapping k)
-> Foldable (Mapping k)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Mapping k a -> f (Mapping k b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Mapping k (f a) -> f (Mapping k a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Mapping k a -> m (Mapping k b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Mapping k (m a) -> m (Mapping k a))
-> Traversable (Mapping k)
(a -> f b) -> Mapping k a -> f (Mapping k b)
forall k. Functor (Mapping k)
forall k. Foldable (Mapping k)
forall k (m :: * -> *) a.
Monad m =>
Mapping k (m a) -> m (Mapping k a)
forall k (f :: * -> *) a.
Applicative f =>
Mapping k (f a) -> f (Mapping k a)
forall k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Mapping k a -> m (Mapping k b)
forall k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Mapping k a -> f (Mapping k b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Mapping k (m a) -> m (Mapping k a)
forall (f :: * -> *) a.
Applicative f =>
Mapping k (f a) -> f (Mapping k a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Mapping k a -> m (Mapping k b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Mapping k a -> f (Mapping k b)
sequence :: Mapping k (m a) -> m (Mapping k a)
$csequence :: forall k (m :: * -> *) a.
Monad m =>
Mapping k (m a) -> m (Mapping k a)
mapM :: (a -> m b) -> Mapping k a -> m (Mapping k b)
$cmapM :: forall k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Mapping k a -> m (Mapping k b)
sequenceA :: Mapping k (f a) -> f (Mapping k a)
$csequenceA :: forall k (f :: * -> *) a.
Applicative f =>
Mapping k (f a) -> f (Mapping k a)
traverse :: (a -> f b) -> Mapping k a -> f (Mapping k b)
$ctraverse :: forall k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Mapping k a -> f (Mapping k b)
$cp2Traversable :: forall k. Foldable (Mapping k)
$cp1Traversable :: forall k. Functor (Mapping k)
Traversable, (forall x. Mapping k v -> Rep (Mapping k v) x)
-> (forall x. Rep (Mapping k v) x -> Mapping k v)
-> Generic (Mapping k v)
forall x. Rep (Mapping k v) x -> Mapping k v
forall x. Mapping k v -> Rep (Mapping k v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k v x. Rep (Mapping k v) x -> Mapping k v
forall k v x. Mapping k v -> Rep (Mapping k v) x
$cto :: forall k v x. Rep (Mapping k v) x -> Mapping k v
$cfrom :: forall k v x. Mapping k v -> Rep (Mapping k v) x
Generic)

instance (Hashable k, Hashable v) => Hashable (Mapping k v) where
  hashWithSalt :: Int -> Mapping k v -> Int
hashWithSalt Int
s (Mapping Importance
i HashMap k v
m) = Int -> (Importance, HashMap k v) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Importance
i, HashMap k v
m)

data NameType
  = Constructor -- ^ Global constructor or variable
  | LocalVar    -- ^ Local variable
  | Annotation  -- ^ User annotation
  deriving (NameType -> NameType -> Bool
(NameType -> NameType -> Bool)
-> (NameType -> NameType -> Bool) -> Eq NameType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NameType -> NameType -> Bool
$c/= :: NameType -> NameType -> Bool
== :: NameType -> NameType -> Bool
$c== :: NameType -> NameType -> Bool
Eq, Int -> NameType -> ShowS
[NameType] -> ShowS
NameType -> String
(Int -> NameType -> ShowS)
-> (NameType -> String) -> ([NameType] -> ShowS) -> Show NameType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NameType] -> ShowS
$cshowList :: [NameType] -> ShowS
show :: NameType -> String
$cshow :: NameType -> String
showsPrec :: Int -> NameType -> ShowS
$cshowsPrec :: Int -> NameType -> ShowS
Show, (forall x. NameType -> Rep NameType x)
-> (forall x. Rep NameType x -> NameType) -> Generic NameType
forall x. Rep NameType x -> NameType
forall x. NameType -> Rep NameType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NameType x -> NameType
$cfrom :: forall x. NameType -> Rep NameType x
Generic, Int -> NameType
NameType -> Int
NameType -> [NameType]
NameType -> NameType
NameType -> NameType -> [NameType]
NameType -> NameType -> NameType -> [NameType]
(NameType -> NameType)
-> (NameType -> NameType)
-> (Int -> NameType)
-> (NameType -> Int)
-> (NameType -> [NameType])
-> (NameType -> NameType -> [NameType])
-> (NameType -> NameType -> [NameType])
-> (NameType -> NameType -> NameType -> [NameType])
-> Enum NameType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: NameType -> NameType -> NameType -> [NameType]
$cenumFromThenTo :: NameType -> NameType -> NameType -> [NameType]
enumFromTo :: NameType -> NameType -> [NameType]
$cenumFromTo :: NameType -> NameType -> [NameType]
enumFromThen :: NameType -> NameType -> [NameType]
$cenumFromThen :: NameType -> NameType -> [NameType]
enumFrom :: NameType -> [NameType]
$cenumFrom :: NameType -> [NameType]
fromEnum :: NameType -> Int
$cfromEnum :: NameType -> Int
toEnum :: Int -> NameType
$ctoEnum :: Int -> NameType
pred :: NameType -> NameType
$cpred :: NameType -> NameType
succ :: NameType -> NameType
$csucc :: NameType -> NameType
Enum, NameType
NameType -> NameType -> Bounded NameType
forall a. a -> a -> Bounded a
maxBound :: NameType
$cmaxBound :: NameType
minBound :: NameType
$cminBound :: NameType
Bounded)

instance Hashable NameType

-- | Description of a constructor or variable
data Constr
  = Tuple
  | List
  | Named NameType Text
  deriving (Constr -> Constr -> Bool
(Constr -> Constr -> Bool)
-> (Constr -> Constr -> Bool) -> Eq Constr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Constr -> Constr -> Bool
$c/= :: Constr -> Constr -> Bool
== :: Constr -> Constr -> Bool
$c== :: Constr -> Constr -> Bool
Eq, Int -> Constr -> ShowS
[Constr] -> ShowS
Constr -> String
(Int -> Constr -> ShowS)
-> (Constr -> String) -> ([Constr] -> ShowS) -> Show Constr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Constr] -> ShowS
$cshowList :: [Constr] -> ShowS
show :: Constr -> String
$cshow :: Constr -> String
showsPrec :: Int -> Constr -> ShowS
$cshowsPrec :: Int -> Constr -> ShowS
Show, (forall x. Constr -> Rep Constr x)
-> (forall x. Rep Constr x -> Constr) -> Generic Constr
forall x. Rep Constr x -> Constr
forall x. Constr -> Rep Constr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Constr x -> Constr
$cfrom :: forall x. Constr -> Rep Constr x
Generic)

-- | Creates a 'Named' constructor/variable
instance IsString Constr where
  fromString :: String -> Constr
fromString = NameType -> Text -> Constr
Named NameType
Constructor (Text -> Constr) -> (String -> Text) -> String -> Constr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

instance Hashable Constr

-- | Representation of abstract syntax and values
--
-- 'AST' is parameterized by the representation of numbers. This makes it
-- possible to affect the exactness of comparisons. For example a newtype with
-- approximate equality can be used instead of e.g. 'Double'.
data AST n
  = Number n                 -- ^ Numeric literal
  | Text Text                -- ^ Text literal
  | App Constr [AST n]       -- ^ Application of constructor or variable
  | Let Text (AST n) (AST n) -- ^ @`Let` v a body@ binds @v@ to @a@ in @body@
  | Record (Mapping Field (AST n))
  deriving (AST n -> AST n -> Bool
(AST n -> AST n -> Bool) -> (AST n -> AST n -> Bool) -> Eq (AST n)
forall n. Eq n => AST n -> AST n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AST n -> AST n -> Bool
$c/= :: forall n. Eq n => AST n -> AST n -> Bool
== :: AST n -> AST n -> Bool
$c== :: forall n. Eq n => AST n -> AST n -> Bool
Eq, Int -> AST n -> ShowS
[AST n] -> ShowS
AST n -> String
(Int -> AST n -> ShowS)
-> (AST n -> String) -> ([AST n] -> ShowS) -> Show (AST n)
forall n. Show n => Int -> AST n -> ShowS
forall n. Show n => [AST n] -> ShowS
forall n. Show n => AST n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AST n] -> ShowS
$cshowList :: forall n. Show n => [AST n] -> ShowS
show :: AST n -> String
$cshow :: forall n. Show n => AST n -> String
showsPrec :: Int -> AST n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> AST n -> ShowS
Show, AST a -> Bool
(a -> m) -> AST a -> m
(a -> b -> b) -> b -> AST a -> b
(forall m. Monoid m => AST m -> m)
-> (forall m a. Monoid m => (a -> m) -> AST a -> m)
-> (forall m a. Monoid m => (a -> m) -> AST a -> m)
-> (forall a b. (a -> b -> b) -> b -> AST a -> b)
-> (forall a b. (a -> b -> b) -> b -> AST a -> b)
-> (forall b a. (b -> a -> b) -> b -> AST a -> b)
-> (forall b a. (b -> a -> b) -> b -> AST a -> b)
-> (forall a. (a -> a -> a) -> AST a -> a)
-> (forall a. (a -> a -> a) -> AST a -> a)
-> (forall a. AST a -> [a])
-> (forall a. AST a -> Bool)
-> (forall a. AST a -> Int)
-> (forall a. Eq a => a -> AST a -> Bool)
-> (forall a. Ord a => AST a -> a)
-> (forall a. Ord a => AST a -> a)
-> (forall a. Num a => AST a -> a)
-> (forall a. Num a => AST a -> a)
-> Foldable AST
forall a. Eq a => a -> AST a -> Bool
forall a. Num a => AST a -> a
forall a. Ord a => AST a -> a
forall m. Monoid m => AST m -> m
forall a. AST a -> Bool
forall a. AST a -> Int
forall a. AST a -> [a]
forall a. (a -> a -> a) -> AST a -> a
forall m a. Monoid m => (a -> m) -> AST a -> m
forall b a. (b -> a -> b) -> b -> AST a -> b
forall a b. (a -> b -> b) -> b -> AST a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: AST a -> a
$cproduct :: forall a. Num a => AST a -> a
sum :: AST a -> a
$csum :: forall a. Num a => AST a -> a
minimum :: AST a -> a
$cminimum :: forall a. Ord a => AST a -> a
maximum :: AST a -> a
$cmaximum :: forall a. Ord a => AST a -> a
elem :: a -> AST a -> Bool
$celem :: forall a. Eq a => a -> AST a -> Bool
length :: AST a -> Int
$clength :: forall a. AST a -> Int
null :: AST a -> Bool
$cnull :: forall a. AST a -> Bool
toList :: AST a -> [a]
$ctoList :: forall a. AST a -> [a]
foldl1 :: (a -> a -> a) -> AST a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AST a -> a
foldr1 :: (a -> a -> a) -> AST a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> AST a -> a
foldl' :: (b -> a -> b) -> b -> AST a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> AST a -> b
foldl :: (b -> a -> b) -> b -> AST a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> AST a -> b
foldr' :: (a -> b -> b) -> b -> AST a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> AST a -> b
foldr :: (a -> b -> b) -> b -> AST a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> AST a -> b
foldMap' :: (a -> m) -> AST a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> AST a -> m
foldMap :: (a -> m) -> AST a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AST a -> m
fold :: AST m -> m
$cfold :: forall m. Monoid m => AST m -> m
Foldable, a -> AST b -> AST a
(a -> b) -> AST a -> AST b
(forall a b. (a -> b) -> AST a -> AST b)
-> (forall a b. a -> AST b -> AST a) -> Functor AST
forall a b. a -> AST b -> AST a
forall a b. (a -> b) -> AST a -> AST b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> AST b -> AST a
$c<$ :: forall a b. a -> AST b -> AST a
fmap :: (a -> b) -> AST a -> AST b
$cfmap :: forall a b. (a -> b) -> AST a -> AST b
Functor, Functor AST
Foldable AST
Functor AST
-> Foldable AST
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> AST a -> f (AST b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    AST (f a) -> f (AST a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> AST a -> m (AST b))
-> (forall (m :: * -> *) a. Monad m => AST (m a) -> m (AST a))
-> Traversable AST
(a -> f b) -> AST a -> f (AST b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => AST (m a) -> m (AST a)
forall (f :: * -> *) a. Applicative f => AST (f a) -> f (AST a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AST a -> m (AST b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AST a -> f (AST b)
sequence :: AST (m a) -> m (AST a)
$csequence :: forall (m :: * -> *) a. Monad m => AST (m a) -> m (AST a)
mapM :: (a -> m b) -> AST a -> m (AST b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AST a -> m (AST b)
sequenceA :: AST (f a) -> f (AST a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => AST (f a) -> f (AST a)
traverse :: (a -> f b) -> AST a -> f (AST b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AST a -> f (AST b)
$cp2Traversable :: Foldable AST
$cp1Traversable :: Functor AST
Traversable, (forall x. AST n -> Rep (AST n) x)
-> (forall x. Rep (AST n) x -> AST n) -> Generic (AST n)
forall x. Rep (AST n) x -> AST n
forall x. AST n -> Rep (AST n) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall n x. Rep (AST n) x -> AST n
forall n x. AST n -> Rep (AST n) x
$cto :: forall n x. Rep (AST n) x -> AST n
$cfrom :: forall n x. AST n -> Rep (AST n) x
Generic)

instance Hashable n => Hashable (AST n)

record :: HasCallStack => Importance -> [(Field, AST n)] -> AST n
record :: Importance -> [(Field, AST n)] -> AST n
record Importance
imp = Mapping Field (AST n) -> AST n
forall n. Mapping Field (AST n) -> AST n
Record (Mapping Field (AST n) -> AST n)
-> ([(Field, AST n)] -> Mapping Field (AST n))
-> [(Field, AST n)]
-> AST n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Importance -> HashMap Field (AST n) -> Mapping Field (AST n)
forall k v. Importance -> HashMap k v -> Mapping k v
Mapping Importance
imp (HashMap Field (AST n) -> Mapping Field (AST n))
-> ([(Field, AST n)] -> HashMap Field (AST n))
-> [(Field, AST n)]
-> Mapping Field (AST n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Field, AST n)] -> HashMap Field (AST n)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList

prettyNamed :: NameType -> Text -> Doc
prettyNamed :: NameType -> Text -> Doc
prettyNamed NameType
Constructor Text
c = String -> Doc
PP.string (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
c
prettyNamed NameType
LocalVar Text
v    = String -> Doc
PP.string (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
v
prettyNamed NameType
Annotation Text
a  = String -> Doc
PP.string (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"ANN: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a

-- | If @k@ is a 'String'-like type, it will be shown with quotes. Use 'Field'
-- to prevent this.
instance {-# OVERLAPPABLE #-}
         (Pretty a, Show k, Ord k) => Pretty (Mapping k a) where
  pretty :: Mapping k a -> Doc
pretty (Mapping Importance
imp HashMap k a
m) = Importance -> HashMap k Doc -> Doc
forall k. (Show k, Ord k) => Importance -> HashMap k Doc -> Doc
prettyRecord Importance
imp (HashMap k Doc -> Doc) -> HashMap k Doc -> Doc
forall a b. (a -> b) -> a -> b
$ a -> Doc
forall a. Pretty a => a -> Doc
pretty (a -> Doc) -> HashMap k a -> HashMap k Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap k a
m

instance Show a => Pretty (AST a) where
  pretty :: AST a -> Doc
pretty (Number a
a) = String -> Doc
PP.string (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
a
  pretty (Text Text
a) = String -> Doc
PP.string (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
a
  pretty (App Constr
Tuple []) = Doc -> Doc
PP.parens Doc
PP.empty
  pretty (App Constr
Tuple [AST a]
vs) =
    Doc -> Doc -> Doc -> [Doc] -> Doc
verticalList Doc
PP.lparen Doc
PP.comma Doc
PP.rparen ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (AST a -> Doc) -> [AST a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map AST a -> Doc
forall a. Pretty a => a -> Doc
pretty [AST a]
vs
  pretty (App Constr
List []) = Doc -> Doc
PP.brackets Doc
PP.empty
  pretty (App Constr
List [AST a]
vs) =
    Doc -> Doc -> Doc -> [Doc] -> Doc
verticalList Doc
PP.lbracket Doc
PP.comma Doc
PP.rbracket ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (AST a -> Doc) -> [AST a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map AST a -> Doc
forall a. Pretty a => a -> Doc
pretty [AST a]
vs
  pretty (App (Named NameType
t Text
c) []) = NameType -> Text -> Doc
prettyNamed NameType
t Text
c
  pretty (App (Named NameType
t Text
c) [AST a]
vs) =
    Doc -> Doc -> Doc
underHeader (NameType -> Text -> Doc
prettyNamed NameType
t Text
c) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
(PP.<$>) ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (AST a -> Doc) -> [AST a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map AST a -> Doc
forall a. Pretty a => a -> Doc
pretty [AST a]
vs
  pretty (Let Text
v AST a
a AST a
b) =
    Doc -> Doc -> Doc
underHeader (String -> Doc
PP.string String
"let" Doc -> Doc -> Doc
PP.<+> Doc
var Doc -> Doc -> Doc
PP.<+> Doc
"=") (AST a -> Doc
forall a. Pretty a => a -> Doc
pretty AST a
a)
      Doc -> Doc -> Doc
PP.<$>
    Doc -> Doc -> Doc
underHeader (String -> Doc
PP.string String
" in") (AST a -> Doc
forall a. Pretty a => a -> Doc
pretty AST a
b)
    where
      var :: Doc
var = String -> Doc
PP.string (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
v
  pretty (Record Mapping Field (AST a)
rec) = Mapping Field (AST a) -> Doc
forall a. Pretty a => a -> Doc
pretty Mapping Field (AST a)
rec



--------------------------------------------------------------------------------
-- * Generic inspection
--------------------------------------------------------------------------------

showSym :: forall sym str. (KnownSymbol sym, IsString str) => str
showSym :: str
showSym = String -> str
forall a. IsString a => String -> a
fromString (String -> str) -> String -> str
forall a b. (a -> b) -> a -> b
$ Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy sym
forall k (t :: k). Proxy t
Proxy @sym)

class GInspectableArgs rep where
  gInspectArgs :: rep x -> [AST Rational]

instance GInspectableArgs U1 where
  gInspectArgs :: U1 x -> [AST Rational]
gInspectArgs U1 x
_ = []

instance Inspectable a =>
         GInspectableArgs (S1 ('MetaSel 'Nothing x y z) (Rec0 a)) where
  gInspectArgs :: S1 ('MetaSel 'Nothing x y z) (Rec0 a) x -> [AST Rational]
gInspectArgs = AST Rational -> [AST Rational]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AST Rational -> [AST Rational])
-> (S1 ('MetaSel 'Nothing x y z) (Rec0 a) x -> AST Rational)
-> S1 ('MetaSel 'Nothing x y z) (Rec0 a) x
-> [AST Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect (a -> AST Rational)
-> (S1 ('MetaSel 'Nothing x y z) (Rec0 a) x -> a)
-> S1 ('MetaSel 'Nothing x y z) (Rec0 a) x
-> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R a x -> a
forall i c k (p :: k). K1 i c p -> c
unK1 (K1 R a x -> a)
-> (S1 ('MetaSel 'Nothing x y z) (Rec0 a) x -> K1 R a x)
-> S1 ('MetaSel 'Nothing x y z) (Rec0 a) x
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 ('MetaSel 'Nothing x y z) (Rec0 a) x -> K1 R a x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GInspectableArgs rep1, GInspectableArgs rep2) =>
         GInspectableArgs (rep1 :*: rep2) where
  gInspectArgs :: (:*:) rep1 rep2 x -> [AST Rational]
gInspectArgs (rep1 x
rep1 :*: rep2 x
rep2) = rep1 x -> [AST Rational]
forall k (rep :: k -> *) (x :: k).
GInspectableArgs rep =>
rep x -> [AST Rational]
gInspectArgs rep1 x
rep1 [AST Rational] -> [AST Rational] -> [AST Rational]
forall a. [a] -> [a] -> [a]
++ rep2 x -> [AST Rational]
forall k (rep :: k -> *) (x :: k).
GInspectableArgs rep =>
rep x -> [AST Rational]
gInspectArgs rep2 x
rep2

class GInspectableFields rep where
  gInspectFields :: rep x -> [(Field, AST Rational)]

instance GInspectableFields U1 where
  gInspectFields :: U1 x -> [(Field, AST Rational)]
gInspectFields U1 x
_ = []

instance (Inspectable a, KnownSymbol fld) =>
         GInspectableFields (S1 ('MetaSel ('Just fld) x y z) (Rec0 a)) where
  gInspectFields :: S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x
-> [(Field, AST Rational)]
gInspectFields = (Field, AST Rational) -> [(Field, AST Rational)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Field, AST Rational) -> [(Field, AST Rational)])
-> (S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x
    -> (Field, AST Rational))
-> S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x
-> [(Field, AST Rational)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall str. (KnownSymbol fld, IsString str) => str
forall (sym :: Symbol) str. (KnownSymbol sym, IsString str) => str
showSym @fld, ) (AST Rational -> (Field, AST Rational))
-> (S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x -> AST Rational)
-> S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x
-> (Field, AST Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect (a -> AST Rational)
-> (S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x -> a)
-> S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x
-> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R a x -> a
forall i c k (p :: k). K1 i c p -> c
unK1 (K1 R a x -> a)
-> (S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x -> K1 R a x)
-> S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 ('MetaSel ('Just fld) x y z) (Rec0 a) x -> K1 R a x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GInspectableFields rep1, GInspectableFields rep2) =>
         GInspectableFields (rep1 :*: rep2) where
  gInspectFields :: (:*:) rep1 rep2 x -> [(Field, AST Rational)]
gInspectFields (rep1 x
rep1 :*: rep2 x
rep2) = rep1 x -> [(Field, AST Rational)]
forall k (rep :: k -> *) (x :: k).
GInspectableFields rep =>
rep x -> [(Field, AST Rational)]
gInspectFields rep1 x
rep1 [(Field, AST Rational)]
-> [(Field, AST Rational)] -> [(Field, AST Rational)]
forall a. [a] -> [a] -> [a]
++ rep2 x -> [(Field, AST Rational)]
forall k (rep :: k -> *) (x :: k).
GInspectableFields rep =>
rep x -> [(Field, AST Rational)]
gInspectFields rep2 x
rep2

class GInspectable rep where
  gInspect :: rep x -> AST Rational

instance (GInspectable rep1, GInspectable rep2) =>
         GInspectable (rep1 :+: rep2) where
  gInspect :: (:+:) rep1 rep2 x -> AST Rational
gInspect (L1 rep1 x
rep) = rep1 x -> AST Rational
forall k (rep :: k -> *) (x :: k).
GInspectable rep =>
rep x -> AST Rational
gInspect rep1 x
rep
  gInspect (R1 rep2 x
rep) = rep2 x -> AST Rational
forall k (rep :: k -> *) (x :: k).
GInspectable rep =>
rep x -> AST Rational
gInspect rep2 x
rep

instance GInspectable rep => GInspectable (D1 meta rep) where
  gInspect :: D1 meta rep x -> AST Rational
gInspect = rep x -> AST Rational
forall k (rep :: k -> *) (x :: k).
GInspectable rep =>
rep x -> AST Rational
gInspect (rep x -> AST Rational)
-> (D1 meta rep x -> rep x) -> D1 meta rep x -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 meta rep x -> rep x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GInspectableArgs rep, KnownSymbol con) =>
         GInspectable (C1 ('MetaCons con x 'False) rep) where
  gInspect :: C1 ('MetaCons con x 'False) rep x -> AST Rational
gInspect = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App (forall str. (KnownSymbol con, IsString str) => str
forall (sym :: Symbol) str. (KnownSymbol sym, IsString str) => str
showSym @con) ([AST Rational] -> AST Rational)
-> (C1 ('MetaCons con x 'False) rep x -> [AST Rational])
-> C1 ('MetaCons con x 'False) rep x
-> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. rep x -> [AST Rational]
forall k (rep :: k -> *) (x :: k).
GInspectableArgs rep =>
rep x -> [AST Rational]
gInspectArgs (rep x -> [AST Rational])
-> (C1 ('MetaCons con x 'False) rep x -> rep x)
-> C1 ('MetaCons con x 'False) rep x
-> [AST Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 ('MetaCons con x 'False) rep x -> rep x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GInspectableFields rep, KnownSymbol con) =>
         GInspectable (C1 ('MetaCons con x 'True) rep) where
  gInspect :: C1 ('MetaCons con x 'True) rep x -> AST Rational
gInspect =
    Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App (forall str. (KnownSymbol con, IsString str) => str
forall (sym :: Symbol) str. (KnownSymbol sym, IsString str) => str
showSym @con) ([AST Rational] -> AST Rational)
-> (C1 ('MetaCons con x 'True) rep x -> [AST Rational])
-> C1 ('MetaCons con x 'True) rep x
-> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    AST Rational -> [AST Rational]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AST Rational -> [AST Rational])
-> (C1 ('MetaCons con x 'True) rep x -> AST Rational)
-> C1 ('MetaCons con x 'True) rep x
-> [AST Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mapping Field (AST Rational) -> AST Rational
forall n. Mapping Field (AST n) -> AST n
Record (Mapping Field (AST Rational) -> AST Rational)
-> (C1 ('MetaCons con x 'True) rep x
    -> Mapping Field (AST Rational))
-> C1 ('MetaCons con x 'True) rep x
-> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Importance
-> HashMap Field (AST Rational) -> Mapping Field (AST Rational)
forall k v. Importance -> HashMap k v -> Mapping k v
Mapping Importance
Unimportant (HashMap Field (AST Rational) -> Mapping Field (AST Rational))
-> (C1 ('MetaCons con x 'True) rep x
    -> HashMap Field (AST Rational))
-> C1 ('MetaCons con x 'True) rep x
-> Mapping Field (AST Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Field, AST Rational)] -> HashMap Field (AST Rational)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Field, AST Rational)] -> HashMap Field (AST Rational))
-> (C1 ('MetaCons con x 'True) rep x -> [(Field, AST Rational)])
-> C1 ('MetaCons con x 'True) rep x
-> HashMap Field (AST Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. rep x -> [(Field, AST Rational)]
forall k (rep :: k -> *) (x :: k).
GInspectableFields rep =>
rep x -> [(Field, AST Rational)]
gInspectFields (rep x -> [(Field, AST Rational)])
-> (C1 ('MetaCons con x 'True) rep x -> rep x)
-> C1 ('MetaCons con x 'True) rep x
-> [(Field, AST Rational)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 ('MetaCons con x 'True) rep x -> rep x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

class Inspectable a where
  inspect :: a -> AST Rational

  default inspect :: (Generic a, GInspectable (Rep a)) => a -> AST Rational
  inspect = Rep a Any -> AST Rational
forall k (rep :: k -> *) (x :: k).
GInspectable rep =>
rep x -> AST Rational
gInspect (Rep a Any -> AST Rational)
-> (a -> Rep a Any) -> a -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

instance Inspectable Rational where inspect :: Rational -> AST Rational
inspect = Rational -> AST Rational
forall n. n -> AST n
Number
instance Inspectable Int      where inspect :: Int -> AST Rational
inspect = Rational -> AST Rational
forall n. n -> AST n
Number (Rational -> AST Rational)
-> (Int -> Rational) -> Int -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Rational
forall a. Real a => a -> Rational
toRational
instance Inspectable Integer  where inspect :: Integer -> AST Rational
inspect = Rational -> AST Rational
forall n. n -> AST n
Number (Rational -> AST Rational)
-> (Integer -> Rational) -> Integer -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Rational
forall a. Real a => a -> Rational
toRational
instance Inspectable Float    where inspect :: Float -> AST Rational
inspect = Rational -> AST Rational
forall n. n -> AST n
Number (Rational -> AST Rational)
-> (Float -> Rational) -> Float -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Rational
forall a. Real a => a -> Rational
toRational
instance Inspectable Double   where inspect :: Double -> AST Rational
inspect = Rational -> AST Rational
forall n. n -> AST n
Number (Rational -> AST Rational)
-> (Double -> Rational) -> Double -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Rational
forall a. Real a => a -> Rational
toRational

instance Real n => Inspectable (AST n) where
  inspect :: AST n -> AST Rational
inspect = (n -> Rational) -> AST n -> AST Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> Rational
forall a. Real a => a -> Rational
toRational

instance Inspectable () where
  inspect :: () -> AST Rational
inspect () = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App Constr
"()" []

instance Inspectable Bool where
  inspect :: Bool -> AST Rational
inspect Bool
b = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App (String -> Constr
forall a. IsString a => String -> a
fromString (String -> Constr) -> String -> Constr
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
b) []

instance {-# OVERLAPS #-} Inspectable String where
  inspect :: String -> AST Rational
inspect = Text -> AST Rational
forall n. Text -> AST n
Text (Text -> AST Rational)
-> (String -> Text) -> String -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

instance Inspectable Text where
  inspect :: Text -> AST Rational
inspect = Text -> AST Rational
forall n. Text -> AST n
Text

instance Inspectable a => Inspectable (Maybe a) where
  inspect :: Maybe a -> AST Rational
inspect Maybe a
Nothing  = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App Constr
"Nothing" []
  inspect (Just a
a) = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App Constr
"Just" [a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect a
a]

instance {-# OVERLAPPABLE #-} Inspectable a => Inspectable [a] where
  inspect :: [a] -> AST Rational
inspect = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App Constr
List ([AST Rational] -> AST Rational)
-> ([a] -> [AST Rational]) -> [a] -> AST Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> AST Rational) -> [a] -> [AST Rational]
forall a b. (a -> b) -> [a] -> [b]
map a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect

instance Inspectable a => Inspectable (Mapping Field a) where
  inspect :: Mapping Field a -> AST Rational
inspect (Mapping Importance
i HashMap Field a
m) = Mapping Field (AST Rational) -> AST Rational
forall n. Mapping Field (AST n) -> AST n
Record (Mapping Field (AST Rational) -> AST Rational)
-> Mapping Field (AST Rational) -> AST Rational
forall a b. (a -> b) -> a -> b
$ Importance
-> HashMap Field (AST Rational) -> Mapping Field (AST Rational)
forall k v. Importance -> HashMap k v -> Mapping k v
Mapping Importance
i (HashMap Field (AST Rational) -> Mapping Field (AST Rational))
-> HashMap Field (AST Rational) -> Mapping Field (AST Rational)
forall a b. (a -> b) -> a -> b
$ (a -> AST Rational)
-> HashMap Field a -> HashMap Field (AST Rational)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect HashMap Field a
m

instance (Inspectable a, Inspectable b) => Inspectable (a, b) where
  inspect :: (a, b) -> AST Rational
inspect (a
a, b
b) = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App Constr
Tuple [a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect a
a, b -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect b
b]

instance (Inspectable a, Inspectable b, Inspectable c) =>
         Inspectable (a, b, c) where
  inspect :: (a, b, c) -> AST Rational
inspect (a
a, b
b, c
c) = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App Constr
Tuple [a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect a
a, b -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect b
b, c -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect c
c]

instance (Inspectable a, Inspectable b, Inspectable c, Inspectable d) =>
         Inspectable (a, b, c, d) where
  inspect :: (a, b, c, d) -> AST Rational
inspect (a
a, b
b, c
c, d
d) = Constr -> [AST Rational] -> AST Rational
forall n. Constr -> [AST n] -> AST n
App Constr
Tuple [a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect a
a, b -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect b
b, c -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect c
c, d -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect d
d]

-- | Represent a list as a record, if the elements contain a value that can be
-- used as key
inspectListAsRec ::
     Inspectable a
  => Importance
  -> (a -> Field) -- ^ Extract the key
  -> [a]
  -> AST Rational
inspectListAsRec :: Importance -> (a -> Field) -> [a] -> AST Rational
inspectListAsRec Importance
imp a -> Field
getKey [a]
as =
  Mapping Field (AST Rational) -> AST Rational
forall n. Mapping Field (AST n) -> AST n
Record (Mapping Field (AST Rational) -> AST Rational)
-> Mapping Field (AST Rational) -> AST Rational
forall a b. (a -> b) -> a -> b
$ Importance
-> HashMap Field (AST Rational) -> Mapping Field (AST Rational)
forall k v. Importance -> HashMap k v -> Mapping k v
Mapping Importance
imp (HashMap Field (AST Rational) -> Mapping Field (AST Rational))
-> HashMap Field (AST Rational) -> Mapping Field (AST Rational)
forall a b. (a -> b) -> a -> b
$ [(Field, AST Rational)] -> HashMap Field (AST Rational)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(a -> Field
getKey a
a, a -> AST Rational
forall a. Inspectable a => a -> AST Rational
inspect a
a) | a
a <- [a]
as]



--------------------------------------------------------------------------------
-- * Conversion to Tree
--------------------------------------------------------------------------------

renderCon :: Constr -> Text
renderCon :: Constr -> Text
renderCon Constr
Tuple = Text
"#Tuple"
renderCon Constr
List = Text
"#List"
renderCon (Named NameType
t Text
n) = case NameType
t of
  NameType
Constructor -> Text
n
  NameType
LocalVar -> Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n
  NameType
Annotation -> Text
"ANN: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n

tagTree :: Text -> Tree Text -> Tree Text
tagTree :: Text -> Tree Text -> Tree Text
tagTree Text
tag (Node Text
n Forest Text
ts) = Text -> Forest Text -> Tree Text
forall a. a -> Forest a -> Tree a
Node (Text
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n) Forest Text
ts

toTreeRec :: Show n => Mapping Field (AST n) -> [Tree Text]
toTreeRec :: Mapping Field (AST n) -> Forest Text
toTreeRec (Mapping Importance
_ HashMap Field (AST n)
fs) =
  [Text -> Tree Text -> Tree Text
tagTree (String -> Text
Text.pack (Field -> String
unField Field
f) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") (Tree Text -> Tree Text) -> Tree Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ AST n -> Tree Text
forall n. Show n => AST n -> Tree Text
toTree AST n
a | (Field
f, AST n
a) <- HashMap Field (AST n) -> [(Field, AST n)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Field (AST n)
fs]

-- | Conversion from 'AST' to 'Tree'
--
-- * Built-in consturctors (tuples and lists) are shown prepended with @#@.
--
-- * Record fields are shown as @fieldName:@.
--
-- * Local variables are shown as @*varName@ (both at binding and use site).
--
-- * Annotations are shown as "ANN: annotation ".
toTree :: Show n => AST n -> Tree Text
toTree :: AST n -> Tree Text
toTree (App Constr
c [Record Mapping Field (AST n)
rec]) = Text -> Forest Text -> Tree Text
forall a. a -> Forest a -> Tree a
Node (Constr -> Text
renderCon Constr
c) (Forest Text -> Tree Text) -> Forest Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ Mapping Field (AST n) -> Forest Text
forall n. Show n => Mapping Field (AST n) -> Forest Text
toTreeRec Mapping Field (AST n)
rec
toTree (Number n
n)     = Text -> Forest Text -> Tree Text
forall a. a -> Forest a -> Tree a
Node (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ n -> String
forall a. Show a => a -> String
show n
n) []
toTree (Text Text
t)       = Text -> Forest Text -> Tree Text
forall a. a -> Forest a -> Tree a
Node (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
t) []
toTree (App Constr
c [AST n]
as)     = Text -> Forest Text -> Tree Text
forall a. a -> Forest a -> Tree a
Node (Constr -> Text
renderCon Constr
c) (Forest Text -> Tree Text) -> Forest Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ (AST n -> Tree Text) -> [AST n] -> Forest Text
forall a b. (a -> b) -> [a] -> [b]
map AST n -> Tree Text
forall n. Show n => AST n -> Tree Text
toTree [AST n]
as
toTree (Let Text
v AST n
a AST n
body) = Text -> Forest Text -> Tree Text
forall a. a -> Forest a -> Tree a
Node (Text
"Let *" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v) [AST n -> Tree Text
forall n. Show n => AST n -> Tree Text
toTree AST n
a, AST n -> Tree Text
forall n. Show n => AST n -> Tree Text
toTree AST n
body]
toTree (Record Mapping Field (AST n)
fs)    = Text -> Forest Text -> Tree Text
forall a. a -> Forest a -> Tree a
Node Text
"Record" (Forest Text -> Tree Text) -> Forest Text -> Tree Text
forall a b. (a -> b) -> a -> b
$ Mapping Field (AST n) -> Forest Text
forall n. Show n => Mapping Field (AST n) -> Forest Text
toTreeRec Mapping Field (AST n)
fs

-- | Show an 'AST' using Unicode art
showTree :: Show n => AST n -> String
showTree :: AST n -> String
showTree = Tree String -> String
View.showTree (Tree String -> String)
-> (AST n -> Tree String) -> AST n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> Tree Text -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text.unpack (Tree Text -> Tree String)
-> (AST n -> Tree Text) -> AST n -> Tree String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AST n -> Tree Text
forall n. Show n => AST n -> Tree Text
toTree
  -- TODO Convert `tree-view` to `Text`

-- | Draw an 'AST' on the terminal using Unicode art
drawTree :: Show n => AST n -> IO ()
drawTree :: AST n -> IO ()
drawTree = Tree String -> IO ()
View.drawTree (Tree String -> IO ()) -> (AST n -> Tree String) -> AST n -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> Tree Text -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text.unpack (Tree Text -> Tree String)
-> (AST n -> Tree Text) -> AST n -> Tree String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AST n -> Tree Text
forall n. Show n => AST n -> Tree Text
toTree

-- | Convert an 'AST' to an HTML file with foldable nodes
htmlTree :: Show n => FilePath -> AST n -> IO ()
htmlTree :: String -> AST n -> IO ()
htmlTree String
file =
  Maybe String -> String -> Tree NodeInfo -> IO ()
View.writeHtmlTree Maybe String
forall a. Maybe a
Nothing String
file (Tree NodeInfo -> IO ())
-> (AST n -> Tree NodeInfo) -> AST n -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> NodeInfo) -> Tree String -> Tree NodeInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> NodeInfo
mkInfo (Tree String -> Tree NodeInfo)
-> (AST n -> Tree String) -> AST n -> Tree NodeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> Tree Text -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Text.unpack (Tree Text -> Tree String)
-> (AST n -> Tree Text) -> AST n -> Tree String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AST n -> Tree Text
forall n. Show n => AST n -> Tree Text
toTree
  where
    mkInfo :: String -> NodeInfo
mkInfo String
n = Behavior -> String -> String -> NodeInfo
NodeInfo Behavior
InitiallyExpanded String
n String
""