Obj.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}

module Obj where

import Control.Applicative
import Control.Monad.State
import Data.Char
import Data.Hashable
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
import Info
import qualified Map
import Project
import qualified Set
import SymPath
import Types
import TypesToC
import Util

-- | Will the lookup look at other Carp code or at C code. This matters when calling functions, should they assume it's a lambda or a normal C function?
data GlobalMode
  = CarpLand
  | ExternalCode
  deriving (Eq, Show, Ord, Generic)

instance Hashable GlobalMode

-- | Will the lookup look at a global variable
data DefinitionMode
  = AVariable
  | AFunction
  deriving (Eq, Show, Ord, Generic)

instance Hashable DefinitionMode

-- | For local lookups, does the variable live in the current function or is it captured from outside it's body?
data CaptureMode
  = NoCapture
  | Capture Int
  deriving (Eq, Show, Ord, Generic)

instance Hashable CaptureMode

-- | A symbol knows a bit about what it refers to - is it a local scope or a global one? (the latter include modules).
-- | A symbol that is not used for looking up things will use the 'Symbol' case.
data SymbolMode
  = Symbol
  | LookupLocal CaptureMode
  | LookupRecursive
  | LookupGlobal GlobalMode DefinitionMode
  | LookupGlobalOverride String -- Used to emit another name than the one used in the Carp program.
  deriving (Eq, Show, Ord, Generic)

instance Hashable SymbolMode

isLookupGlobal :: SymbolMode -> Bool
isLookupGlobal (LookupGlobal _ _) = True
isLookupGlobal _ = False

isLookupLocal :: SymbolMode -> Bool
isLookupLocal (LookupLocal _) = True
isLookupLocal _ = False

data MatchMode = MatchValue | MatchRef deriving (Eq, Show, Generic)

instance Hashable MatchMode

data Number = Floating Double | Integral Int deriving (Generic)

instance Hashable Number

instance Eq Number where
  (Floating a) == (Floating b) = a == b
  (Integral a) == (Integral b) = a == b
  (Floating a) == (Integral b) = a == fromIntegral b
  (Integral a) == (Floating b) = fromIntegral a == b

instance Ord Number where
  (Floating a) <= (Floating b) = a <= b
  (Integral a) <= (Integral b) = a <= b
  (Floating a) <= (Integral b) = a <= fromIntegral b
  (Integral a) <= (Floating b) = fromIntegral a <= b

instance Num Number where
  (Floating a) + (Floating b) = Floating (a + b)
  (Integral a) + (Integral b) = Integral (a + b)
  (Floating a) + (Integral b) = Floating (a + fromIntegral b)
  (Integral a) + (Floating b) = Floating (fromIntegral a + b)
  (Integral a) * (Integral b) = Integral (a * b)
  (Floating a) * (Floating b) = Floating (a * b)
  (Integral a) * (Floating b) = Floating (fromIntegral a * b)
  (Floating a) * (Integral b) = Floating (a * fromIntegral b)
  negate (Floating a) = Floating (negate a)
  negate (Integral a) = Integral (negate a)
  abs (Floating a) = Floating (abs a)
  abs (Integral a) = Integral (abs a)
  signum (Floating a) = Floating (signum a)
  signum (Integral a) = Integral (signum a)
  fromInteger a = Integral (fromInteger a)

instance Real Number where
  toRational (Integral a) = toRational a
  toRational (Floating a) = toRational a

instance Enum Number where
  toEnum a = Integral (toEnum a)
  fromEnum (Integral a) = fromEnum a
  fromEnum (Floating _) = error "floating fromenum"

instance Fractional Number where
  fromRational a = Floating (fromRational a)
  recip (Floating a) = Floating (recip a)
  recip (Integral _) = error "integral recip"

instance Integral Number where
  quotRem (Integral a) (Integral b) = let (q, r) = quotRem a b in (Integral q, Integral r)
  quotRem _ _ = error "quotRem"
  toInteger (Integral a) = toInteger a
  toInteger _ = error "toInteger"

instance Show Number where
  show (Floating a) = show a
  show (Integral a) = show a

-- | The canonical Lisp object.
data Obj
  = Sym SymPath SymbolMode
  | MultiSym String [SymPath] -- refering to multiple functions with the same name
  | InterfaceSym String -- refering to an interface. TODO: rename to InterfaceLookupSym?
  | Num Ty Number
  | Str String
  | Pattern String
  | Chr Char
  | Bol Bool
  | Lst [XObj]
  | Arr [XObj]
  | StaticArr [XObj]
  | Dict (Map.Map XObj XObj)
  | Closure XObj ClosureContext
  | Defn (Maybe (Set.Set XObj)) -- if this is a lifted lambda it needs the set of captured variables
  | Def
  | Fn (Maybe SymPath) (Set.Set XObj) -- the name of the lifted function, the set of variables this lambda captures, and a dynamic environment
  | Do
  | Let
  | LocalDef
  | While
  | Break
  | If
  | Match MatchMode
  | Mod Env TypeEnv
  | Deftype Ty
  | DefSumtype Ty
  | With
  | External (Maybe String)
  | ExternalType (Maybe String)
  | MetaStub
  | Deftemplate TemplateCreator
  | Instantiate Template
  | Defalias Ty
  | SetBang
  | Macro
  | Dynamic -- DefnDynamic
  | DefDynamic
  | Command CommandFunctionType
  | Primitive PrimitiveFunctionType
  | The
  | Ref
  | Deref
  | Interface Ty [SymPath]
  | C String -- C literal
  deriving (Show, Eq, Generic)

instance Hashable Obj

isGlobalFunc :: XObj -> Bool
isGlobalFunc xobj =
  case xobj of
    XObj (InterfaceSym _) _ (Just FuncTy {}) -> True
    XObj (MultiSym _ _) _ (Just FuncTy {}) -> True
    XObj (Sym _ (LookupGlobal _ _)) _ (Just FuncTy {}) -> True
    XObj (Sym _ (LookupGlobalOverride _)) _ (Just FuncTy {}) -> True
    _ -> False

isNumericLiteral :: XObj -> Bool
isNumericLiteral (XObj (Num _ _) _ _) = True
isNumericLiteral (XObj (Bol _) _ _) = True
isNumericLiteral (XObj (Chr _) _ _) = True
isNumericLiteral _ = False

-- | Is the given XObj an unqualified symbol.
isUnqualifiedSym :: XObj -> Bool
isUnqualifiedSym (XObj (Sym (SymPath [] _) _) _ _) = True
isUnqualifiedSym _ = False

isSym :: XObj -> Bool
isSym (XObj (Sym (SymPath _ _) _) _ _) = True
isSym _ = False

isSpecialSym :: XObj -> Bool
isSpecialSym (XObj (Sym (SymPath [] s) _) _ _) =
  elem s ["defn", "def", "do", "while", "fn", "let", "break", "if", "match", "match-ref", "set!", "the", "ref", "deref", "with"]
isSpecialSym _ = False

isArray :: XObj -> Bool
isArray (XObj (Arr _) _ _) = True
isArray _ = False

isLiteral :: XObj -> Bool
isLiteral (XObj (Num _ _) _ _) = True
isLiteral (XObj (Chr _) _ _) = True
isLiteral (XObj (Bol _) _ _) = True
isLiteral _ = False

isBool :: XObj -> Bool
isBool (XObj (Bol _) _ _) = True
isBool _ = False

isExternalFunction :: XObj -> Bool
isExternalFunction (XObj (Lst (XObj (External _) _ _ : _)) _ _) = True
isExternalFunction _ = False

isTypeDef :: XObj -> Bool
isTypeDef (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _) = True
isTypeDef (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _) = True
isTypeDef (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _) = True
isTypeDef _ = False

isType :: XObj -> Bool
isType (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = True
isType x = isTypeDef x

isMod :: XObj -> Bool
isMod (XObj (Mod _ _) _ _) = True
isMod _ = False

isFn :: XObj -> Bool
isFn (XObj (Lst (XObj (Fn _ _) _ _ : _)) _ _) = True
isFn (XObj (Lst (XObj (Sym (SymPath [] "fn") _) _ _ : _)) _ _) = True
isFn _ = False

-- | This instance is needed for the dynamic Dictionary
instance Ord Obj where
  compare (Str a) (Str b) = compare a b
  compare (Num _ a) (Num _ b) = compare a b
  compare a b = compare (show a) (show b)

-- TODO: handle comparison of lists, arrays and dictionaries

type NullaryPrimitiveCallback = XObj -> Context -> IO (Context, Either EvalError XObj)

type UnaryPrimitiveCallback = XObj -> Context -> XObj -> IO (Context, Either EvalError XObj)

type BinaryPrimitiveCallback = XObj -> Context -> XObj -> XObj -> IO (Context, Either EvalError XObj)

type TernaryPrimitiveCallback = XObj -> Context -> XObj -> XObj -> XObj -> IO (Context, Either EvalError XObj)

type QuaternaryPrimitiveCallback = XObj -> Context -> XObj -> XObj -> XObj -> XObj -> IO (Context, Either EvalError XObj)

type VariadicPrimitiveCallback = XObj -> Context -> [XObj] -> IO (Context, Either EvalError XObj)

-- | The type of primitive functions. See Primitives.hs
data PrimitiveFunctionType
  = NullaryPrimitive NullaryPrimitiveCallback
  | UnaryPrimitive UnaryPrimitiveCallback
  | BinaryPrimitive BinaryPrimitiveCallback
  | TernaryPrimitive TernaryPrimitiveCallback
  | QuaternaryPrimitive QuaternaryPrimitiveCallback
  | VariadicPrimitive VariadicPrimitiveCallback

instance Hashable PrimitiveFunctionType where
  hashWithSalt s = const s

instance Eq PrimitiveFunctionType where
  _ == _ = True

instance Show PrimitiveFunctionType where
  show _ = "Primitive { ... }"

type NullaryCommandCallback = Context -> IO (Context, Either EvalError XObj)

type UnaryCommandCallback = Context -> XObj -> IO (Context, Either EvalError XObj)

type BinaryCommandCallback = Context -> XObj -> XObj -> IO (Context, Either EvalError XObj)

type TernaryCommandCallback = Context -> XObj -> XObj -> XObj -> IO (Context, Either EvalError XObj)

type VariadicCommandCallback = Context -> [XObj] -> IO (Context, Either EvalError XObj)

data CommandFunctionType
  = NullaryCommandFunction NullaryCommandCallback
  | UnaryCommandFunction UnaryCommandCallback
  | BinaryCommandFunction BinaryCommandCallback
  | TernaryCommandFunction TernaryCommandCallback
  | VariadicCommandFunction VariadicCommandCallback

instance Hashable CommandFunctionType where
  hashWithSalt s = const s

instance Eq CommandFunctionType where
  _ == _ = True

instance Show CommandFunctionType where
  show (NullaryCommandFunction _) = "NullaryCommandFunction { ... }"
  show (UnaryCommandFunction _) = "UnaryCommandFunction { ... }"
  show (BinaryCommandFunction _) = "BinaryCommandFunction { ... }"
  show (TernaryCommandFunction _) = "TernaryCommandFunction { ... }"
  show (VariadicCommandFunction _) = "VariadicCommandFunction { ... }"

newtype TemplateCreator = TemplateCreator {getTemplateCreator :: TypeEnv -> Env -> Template}

instance Hashable TemplateCreator where
  hashWithSalt s = const s

instance Show TemplateCreator where
  show _ = "TemplateCreator"

-- | Note: This is to make comparisons of Environments possible, otherwise
-- | they are always different when they contain TemplateCreators.
instance Eq TemplateCreator where
  _ == _ = True

prettyInfoFromXObj :: XObj -> String
prettyInfoFromXObj xobj = maybe "no info" prettyInfo (xobjInfo xobj)

machineReadableInfoFromXObj :: FilePathPrintLength -> XObj -> String
machineReadableInfoFromXObj fppl xobj =
  case xobjInfo xobj of
    Just i -> machineReadableInfo fppl i
    Nothing -> ""

-- | Obj with eXtra information.
data XObj = XObj
  { xobjObj :: Obj,
    xobjInfo :: Maybe Info,
    xobjTy :: Maybe Ty
  }
  deriving (Show, Eq, Ord)

setObj :: XObj -> Obj -> XObj
setObj x o = x {xobjObj = o}

instance Hashable XObj where
  hashWithSalt s XObj {..} = s `hashWithSalt` xobjObj

getBinderDescription :: XObj -> String
getBinderDescription (XObj (Lst (XObj (Defn _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "defn"
getBinderDescription (XObj (Lst (XObj Def _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "def"
getBinderDescription (XObj (Lst (XObj Macro _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "macro"
getBinderDescription (XObj (Lst (XObj DefDynamic _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "defdynamic"
getBinderDescription (XObj (Lst (XObj Dynamic _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "dynamic"
getBinderDescription (XObj (Lst (XObj (Command _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "command"
getBinderDescription (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "primitive"
getBinderDescription (XObj (Lst (XObj (Deftemplate _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "template"
getBinderDescription (XObj (Lst (XObj (Instantiate _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "instantiate"
getBinderDescription (XObj (Lst (XObj (Defalias _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "alias"
getBinderDescription (XObj (Lst (XObj (External _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "external"
getBinderDescription (XObj (Lst (XObj (ExternalType _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "external-type"
getBinderDescription (XObj (Lst (XObj MetaStub _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "meta-stub"
getBinderDescription (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
getBinderDescription (XObj (Lst (XObj (DefSumtype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
getBinderDescription (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "interface"
getBinderDescription (XObj (Mod _ _) _ _) = "module"
getBinderDescription b = error ("Unhandled binder: " ++ show b)

getName :: XObj -> String
getName xobj = show (getPath xobj)

getSimpleName :: XObj -> String
getSimpleName xobj = let SymPath _ name = getPath xobj in name

getSimpleNameWithArgs :: XObj -> Maybe String
getSimpleNameWithArgs xobj@(XObj (Lst (XObj (Defn _) _ _ : _ : XObj (Arr args) _ _ : _)) _ _) =
  Just $
    "(" ++ getSimpleName xobj ++ (if not (null args) then " " else "")
      ++ unwords (map getSimpleName args)
      ++ ")"
getSimpleNameWithArgs xobj@(XObj (Lst (XObj Macro _ _ : _ : XObj (Arr args) _ _ : _)) _ _) =
  Just $
    "(" ++ getSimpleName xobj ++ (if not (null args) then " " else "")
      ++ unwords (map getSimpleName args)
      ++ ")"
getSimpleNameWithArgs xobj@(XObj (Lst (XObj Dynamic _ _ : _ : XObj (Arr args) _ _ : _)) _ _) =
  Just $
    "(" ++ getSimpleName xobj ++ (if not (null args) then " " else "")
      ++ unwords (map getSimpleName args)
      ++ ")"
getSimpleNameWithArgs _ = Nothing

-- | Extracts the second form (where the name of definitions are stored) from a list of XObj:s.
getPath :: XObj -> SymPath
getPath (XObj (Lst (XObj (Defn _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj Def _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj LocalDef _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj Macro _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj Dynamic _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj DefDynamic _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Deftemplate _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Instantiate _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Defalias _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (External _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (ExternalType _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj MetaStub _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Mod _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Command _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Sym path _) _ _) = path
getPath x = SymPath [] (pretty x)

getBinderPath :: Binder -> SymPath
getBinderPath = getPath . binderXObj

-- | Changes the second form (where the name of definitions are stored) in a list of XObj:s.
setPath :: XObj -> SymPath -> XObj
setPath (XObj (Lst (defn@(XObj (Defn _) _ _) : XObj (Sym _ _) si st : rest)) i t) newPath =
  XObj (Lst (defn : XObj (Sym newPath Symbol) si st : rest)) i t
setPath (XObj (Lst [extr@(XObj (External _) _ _), XObj (Sym _ _) si st, ty]) i t) newPath =
  XObj (Lst [extr, XObj (Sym newPath Symbol) si st, ty]) i t
setPath (XObj (Lst (def@(XObj Def _ _) : XObj (Sym _ _) si st : rest)) i t) newPath =
  XObj (Lst (def : XObj (Sym newPath Symbol) si st : rest)) i t
setPath x _ =
  error ("Can't set path on " ++ show x)

-- | Convert an Obj to a pretty string representation.
-- | Reuses `pretty`.
prettyObj :: Obj -> String
prettyObj = pretty . buildXObj
  where
    buildXObj o = XObj o Nothing Nothing

-- | Convert an XObj to a pretty string representation.
pretty :: XObj -> String
pretty = visit 0
  where
    visit :: Int -> XObj -> String
    visit indent xobj =
      case xobjObj xobj of
        C c -> show c
        Lst lst -> "(" ++ joinWithSpace (map (visit indent) lst) ++ ")"
        Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]"
        StaticArr arr -> "$[" ++ joinWithSpace (map (visit indent) arr) ++ "]"
        Dict dict -> "{" ++ joinWithSpace (map (visit indent) (concatMap (\(a, b) -> [a, b]) (Map.toList dict))) ++ "}"
        Num IntTy num -> show num
        Num LongTy num -> show num ++ "l"
        Num ByteTy num -> show num ++ "b"
        Num FloatTy num -> show num ++ "f"
        Num DoubleTy num -> show num
        Num _ _ -> error "Invalid number type."
        Str str -> show str
        Pattern str -> '#' : show str
        Chr c -> '\\' : c : ""
        Sym path _ -> show path -- ++ " <" ++ show mode ++ ">"
        MultiSym originalName paths -> originalName ++ "{" ++ joinWithComma (map show paths) ++ "}"
        InterfaceSym name -> name -- ++ "§"
        Bol b -> if b then "true" else "false"
        Defn maybeCaptures ->
          "defn" ++ case maybeCaptures of
            Just captures -> " <" ++ prettyCaptures captures ++ ">"
            Nothing -> ""
        Def -> "def"
        Fn _ captures -> "fn" ++ " <" ++ prettyCaptures captures ++ ">"
        Closure elt _ -> "closure<" ++ pretty elt ++ ">"
        If -> "if"
        Match MatchValue -> "match"
        Match MatchRef -> "match-ref"
        While -> "while"
        Do -> "do"
        Let -> "let"
        LocalDef -> "local-binding"
        Mod env _ -> fromMaybe "module" (envModuleName env)
        Deftype _ -> "deftype"
        DefSumtype _ -> "deftype"
        Deftemplate _ -> "deftemplate"
        Instantiate _ -> "instantiate"
        External Nothing -> "external"
        External (Just override) -> "external (override: " ++ show override ++ ")"
        ExternalType Nothing -> "external-type"
        ExternalType (Just override) -> "external-type (override: " ++ show override ++ ")"
        MetaStub -> "meta-stub"
        Defalias _ -> "defalias"
        SetBang -> "set!"
        Macro -> "macro"
        Dynamic -> "dynamic"
        DefDynamic -> "defdynamic"
        Command _ -> "command"
        Primitive _ -> "primitive"
        The -> "the"
        Ref -> "ref"
        Deref -> "deref"
        Break -> "break"
        Interface _ _ -> "interface"
        With -> "with"

prettyUpTo :: Int -> XObj -> String
prettyUpTo lim xobj =
  let prettied = pretty xobj
   in if length prettied > lim
        then take lim prettied ++ "..." ++ end
        else prettied
  where
    end =
      -- we match all of them explicitly to get errors if we forget one
      case xobjObj xobj of
        Lst _ -> ")"
        Arr _ -> "]"
        StaticArr _ -> "]"
        Dict _ -> "}"
        Num LongTy _ -> "l"
        Num IntTy _ -> ""
        Num ByteTy _ -> "b"
        Num FloatTy _ -> "f"
        Num DoubleTy _ -> ""
        Num _ _ -> error "Invalid number type."
        Str _ -> ""
        C _ -> ""
        Pattern _ -> ""
        Chr _ -> ""
        Sym _ _ -> ""
        MultiSym _ _ -> "}"
        InterfaceSym _ -> ""
        Bol _ -> ""
        Defn maybeCaptures ->
          case maybeCaptures of
            Just _ -> ">"
            Nothing -> ""
        Def -> ""
        Fn _ _ -> ">"
        Closure _ _ -> ">"
        If -> ""
        Match _ -> ""
        While -> ""
        Do -> ""
        Let -> ""
        LocalDef -> ""
        Mod _ _ -> ""
        Deftype _ -> ""
        DefSumtype _ -> ""
        Deftemplate _ -> ""
        Instantiate _ -> ""
        External Nothing -> ""
        External (Just _) -> ")"
        ExternalType Nothing -> ""
        ExternalType (Just _) -> ")"
        MetaStub -> ""
        Defalias _ -> ""
        SetBang -> ""
        Macro -> ""
        Dynamic -> ""
        DefDynamic -> ""
        Command _ -> ""
        Primitive _ -> ""
        The -> ""
        Ref -> ""
        Deref -> ""
        Break -> ""
        Interface _ _ -> ""
        With -> ""

prettyCaptures :: Set.Set XObj -> String
prettyCaptures captures =
  joinWithComma (map (\x -> getName x ++ " : " ++ maybe "" show (xobjTy x)) (Set.toList captures))

data EvalError
  = EvalError String [XObj] FilePathPrintLength (Maybe Info)
  | HasStaticCall XObj (Maybe Info)
  deriving (Eq)

instance Show EvalError where
  show (HasStaticCall xobj info) = "Expression " ++ pretty xobj ++ " has unexpected static call" ++ showInfo info
    where
      showInfo (Just i) = " at " ++ prettyInfo i ++ "."
      showInfo Nothing = ""
  show (EvalError msg t fppl info) = msg ++ showInfo info ++ getTrace
    where
      showInfo (Just i) = " at " ++ machineReadableInfo fppl i ++ "."
      showInfo Nothing = ""
      getTrace =
        if null t
          then ""
          else
            "\n\nTraceback:\n  "
              ++ unlines (map (\x -> prettyUpTo 60 x ++ showInfo (xobjInfo x)) t)

-- | Get the type of an XObj as a string.
typeStr :: XObj -> String
typeStr xobj = case xobjTy xobj of
  Nothing -> "" --" : _"
  Just t -> " : " ++ show t

-- | Get the identifier of an XObj as a string.
identifierStr :: XObj -> String
identifierStr xobj = case xobjInfo xobj of
  Just i -> "#" ++ show (infoIdentifier i)
  Nothing -> "#?"

-- | Get the deleters of an XObj as a string.
deletersStr :: XObj -> String
deletersStr xobj = case xobjInfo xobj of
  Just i -> joinWithComma (map show (Set.toList (infoDelete i)))
  Nothing -> ""

-- | Convert XObj to pretty string representation with type annotations.
prettyTyped :: XObj -> String
prettyTyped = visit 0
  where
    visit :: Int -> XObj -> String
    visit indent xobj =
      let suffix =
            typeStr xobj ++ " "
              ++ identifierStr xobj
              ++ " "
              ++ deletersStr xobj
              ++ " "
              ++ "\n"
       in case xobjObj xobj of
            Lst lst ->
              listPrinter "(" ")" lst suffix indent
            Arr arr ->
              listPrinter "[" "]" arr suffix indent
            StaticArr arr ->
              listPrinter "$[" "]" arr suffix indent
            _ ->
              pretty xobj ++ suffix
    listPrinter :: String -> String -> [XObj] -> String -> Int -> String
    listPrinter opening closing xobjs suffix indent =
      opening ++ "   "
        ++ joinWith (spaces (indent + 4)) (map (visit (indent + 4)) xobjs)
        ++ spaces indent
        ++ closing
        ++ suffix

spaces :: Int -> String
spaces n = replicate n ' '

-- | Datatype for holding meta data about a binder, like type annotation or docstring.
newtype MetaData = MetaData {getMeta :: Map.Map String XObj} deriving (Eq, Show, Generic)

instance Hashable MetaData

emptyMeta :: MetaData
emptyMeta = MetaData Map.empty

metaIsTrue :: MetaData -> String -> Bool
metaIsTrue metaData key =
  case Map.lookup key (getMeta metaData) of
    Just (XObj (Bol True) _ _) -> True
    _ -> False

-- | Wraps and holds an XObj in an environment.
data Binder = Binder {binderMeta :: MetaData, binderXObj :: XObj} deriving (Eq, Generic)

instance Hashable Binder

instance Show Binder where
  show binder = showBinderIndented 0 False (getName (binderXObj binder), binder)

-- | Show a binder even if its hidden.
forceShowBinder :: Binder -> String
forceShowBinder binder = showBinderIndented 0 True (getName (binderXObj binder), binder)

showBinderIndented :: Int -> Bool -> (String, Binder) -> String
showBinderIndented indent _ (name, Binder _ (XObj (Mod env tenv) _ _)) =
  replicate indent ' ' ++ name ++ " : Module = {\n"
    ++ prettyEnvironmentIndented (indent + 4) env
    ++ "\n"
    ++ prettyEnvironmentIndented (indent + 4) (getTypeEnv tenv)
    ++ "\n"
    ++ replicate indent ' '
    ++ "}"
showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths) _ _, _]) _ _)) =
  replicate indent ' ' ++ name ++ " : " ++ show t ++ " = {\n    "
    ++ joinWith "\n    " (map show paths)
    ++ "\n"
    ++ replicate indent ' '
    ++ "}"
showBinderIndented indent showHidden (name, Binder meta xobj) =
  if not showHidden && metaIsTrue meta "hidden"
    then ""
    else
      replicate indent ' ' ++ name
        ++
        -- " (" ++ show (getPath xobj) ++ ")" ++
        " : "
        ++ showMaybeTy (xobjTy xobj)

-- ++ " <" ++ getBinderDescription xobj ++ ">"

-- | Get a list of pairs from a deftype declaration.
memberXObjsToPairs :: [XObj] -> [(String, Ty)]
memberXObjsToPairs xobjs = map (\(n, t) -> (mangle (getName n), fromJustWithErrorMessage (xobjToTy t) ("Failed to convert " ++ show t ++ "\nPRETTY: " ++ pretty t ++ " from xobj to type."))) (pairwise xobjs)

fromJustWithErrorMessage :: Maybe Ty -> String -> Ty
fromJustWithErrorMessage (Just x) _ = x
fromJustWithErrorMessage Nothing msg = error msg

-- | Helper function to create binding pairs for registering external functions.
register :: String -> Ty -> (String, Binder)
register name t =
  ( name,
    Binder
      emptyMeta
      ( XObj
          ( Lst
              [ XObj (External Nothing) Nothing Nothing,
                XObj (Sym (SymPath [] name) Symbol) Nothing Nothing
              ]
          )
          (Just dummyInfo)
          (Just t)
      )
  )

data EnvMode = ExternalEnv | InternalEnv | RecursionEnv deriving (Show, Eq, Generic)

instance Hashable EnvMode

-- | Environment
data Env = Env
  { envBindings :: Map.Map String Binder,
    envParent :: Maybe Env,
    envModuleName :: Maybe String,
    envUseModules :: Set.Set SymPath,
    envMode :: EnvMode,
    envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting
  }
  deriving (Show, Eq, Generic)

instance Hashable Env

newtype ClosureContext = CCtx Context
  deriving (Show, Generic)

instance Hashable ClosureContext

instance Eq ClosureContext where
  _ == _ = True

newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic, Eq)

instance Hashable TypeEnv

instance Show TypeEnv where
  show (TypeEnv env) = "(TypeEnv " ++ show env ++ ")"

safeEnvModuleName :: Env -> String
safeEnvModuleName env =
  case envModuleName env of
    Just name -> name ++ ", with parent " ++ parent
    Nothing -> "???, with parent " ++ parent
  where
    parent = maybe "Global" safeEnvModuleName (envParent env)

-- | Used by the compiler command "(env)"
prettyEnvironment :: Env -> String
prettyEnvironment = prettyEnvironmentIndented 0

prettyEnvironmentIndented :: Int -> Env -> String
prettyEnvironmentIndented indent env =
  joinLines $
    filter (/= "") (map (showBinderIndented indent False) (Map.toList (envBindings env)))
      ++ let modules = envUseModules env
          in if null modules
               then []
               else ("\n" ++ replicate indent ' ' ++ "Used modules:") : Set.toList (Set.map (showImportIndented indent) modules)

-- | For debugging nested environments
prettyEnvironmentChain :: Env -> String
prettyEnvironmentChain env =
  let bs = envBindings env
      name = fromMaybe "<env has no name>" (envModuleName env)
      otherInfo = "(" ++ show (envMode env) ++ ", lvl " ++ show (envFunctionNestingLevel env) ++ ")"
   in ( if length bs < 20
          then
            "'" ++ name ++ "' " ++ otherInfo ++ ":\n"
              ++ joinLines
                ( filter
                    (/= "")
                    (map (showBinderIndented 4 False) (Map.toList (envBindings env)))
                )
          else "'" ++ name ++ "' " ++ otherInfo ++ ":\n    Too big to show bindings."
      )
        ++ ( case envParent env of
               Just parent -> "\nWITH PARENT ENV " ++ prettyEnvironmentChain parent
               Nothing -> ""
           )

pathToEnv :: Env -> [String]
pathToEnv rootEnv = reverse (visit rootEnv)
  where
    visit env =
      case envModuleName env of
        Just name -> name : parent
        Nothing -> parent
      where
        parent = maybe [] visit (envParent env)

showImportIndented :: Int -> SymPath -> String
showImportIndented indent path = replicate indent ' ' ++ " * " ++ show path

incrementEnvNestLevel :: Env -> Env
incrementEnvNestLevel env =
  let current = envFunctionNestingLevel env
   in env {envFunctionNestingLevel = current + 1}

-- | Converts an S-expression to one of the Carp types.
xobjToTy :: XObj -> Maybe Ty
xobjToTy (XObj (Sym (SymPath _ "C") _) _ _) = Just CTy
xobjToTy (XObj (Sym (SymPath _ "Unit") _) _ _) = Just UnitTy
xobjToTy (XObj (Sym (SymPath _ "Int") _) _ _) = Just IntTy
xobjToTy (XObj (Sym (SymPath _ "Float") _) _ _) = Just FloatTy
xobjToTy (XObj (Sym (SymPath _ "Double") _) _ _) = Just DoubleTy
xobjToTy (XObj (Sym (SymPath _ "Long") _) _ _) = Just LongTy
xobjToTy (XObj (Sym (SymPath _ "Byte") _) _ _) = Just ByteTy
xobjToTy (XObj (Sym (SymPath _ "String") _) _ _) = Just StringTy
xobjToTy (XObj (Sym (SymPath _ "Pattern") _) _ _) = Just PatternTy
xobjToTy (XObj (Sym (SymPath _ "Char") _) _ _) = Just CharTy
xobjToTy (XObj (Sym (SymPath _ "Bool") _) _ _) = Just BoolTy
xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy
xobjToTy (XObj (Sym spath@(SymPath _ s@(firstLetter : _)) _) _ _)
  | isLower firstLetter = Just (VarTy s)
  | otherwise = Just (StructTy (ConcreteNameTy spath) [])
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
  do
    okInnerTy <- xobjToTy innerTy
    pure (PointerTy okInnerTy)
xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ptr") _) _ _ : _)) _ _) =
  Nothing
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ref") _) _ _, innerTy]) i _) =
  do
    okInnerTy <- xobjToTy innerTy
    pure (RefTy okInnerTy (VarTy (makeTypeVariableNameFromInfo i)))
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ref") _) _ _, innerTy, lifetimeTy]) _ _) =
  do
    okInnerTy <- xobjToTy innerTy
    okLifetimeTy <- xobjToTy lifetimeTy
    pure (RefTy okInnerTy okLifetimeTy)
xobjToTy (XObj (Lst [XObj Ref _ _, innerTy]) i _) =
  -- This enables parsing of '&'
  do
    okInnerTy <- xobjToTy innerTy
    pure (RefTy okInnerTy (VarTy (makeTypeVariableNameFromInfo i)))
xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ref") _) _ _ : _)) _ _) =
  Nothing
xobjToTy (XObj (Lst [XObj (Sym (SymPath path "╬╗") _) fi ft, XObj (Arr argTys) ai at, retTy]) i t) =
  xobjToTy (XObj (Lst [XObj (Sym (SymPath path "Fn") Symbol) fi ft, XObj (Arr argTys) ai at, retTy]) i t)
xobjToTy (XObj (Lst [XObj (Sym (SymPath path "λ") _) fi ft, XObj (Arr argTys) ai at, retTy]) i t) =
  xobjToTy (XObj (Lst [XObj (Sym (SymPath path "Fn") Symbol) fi ft, XObj (Arr argTys) ai at, retTy]) i t)
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn") _) _ _, XObj (Arr argTys) _ _, retTy]) _ _) =
  do
    okArgTys <- mapM xobjToTy argTys
    okRetTy <- xobjToTy retTy
    pure (FuncTy okArgTys okRetTy StaticLifetimeTy)
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn") _) _ _, XObj (Arr argTys) _ _, retTy, lifetime]) _ _) =
  do
    okArgTys <- mapM xobjToTy argTys
    okRetTy <- xobjToTy retTy
    _ <- xobjToTy lifetime
    pure (FuncTy okArgTys okRetTy StaticLifetimeTy)
xobjToTy (XObj (Lst []) _ _) = Just UnitTy
xobjToTy (XObj (Lst (x : xs)) _ _) =
  do
    okX <- xobjToTy x
    okXS <- mapM xobjToTy xs
    case okX of
      (StructTy n []) -> pure (StructTy n okXS)
      v@(VarTy _) -> pure (StructTy v okXS) -- Struct type with type variable as a name, i.e. "(a b)"
      _ -> Nothing
xobjToTy _ = Nothing

-- | Generates the suffix added to polymorphic functions when they are instantiated.
--   For example                (defn id [x] x) : t -> t
--   might be invoked like this (id 5)
--   which will generate        int id__Int(int x) { return x; }
--   The "__Int" is the suffix!
polymorphicSuffix :: Ty -> Ty -> String
polymorphicSuffix signature actualType =
  case evalState (visit signature actualType) [] of
    [] -> ""
    parts -> "__" ++ intercalate "_" parts
  where
    visit :: Ty -> Ty -> State VisitedTypes [String]
    visit sig actual =
      case (sig, actual) of
        (VarTy _, VarTy _) ->
          -- error $ "Unsolved variable in actual type: " ++ show sig ++ " => " ++ show actual ++
          --        " when calculating polymorphic suffix for " ++
          --        show signature ++ " => " ++ show actualType
          pure ["?"]
        (a@(VarTy _), b) -> do
          visitedTypeVariables <- get
          if a `elem` visitedTypeVariables
            then pure []
            else do
              put (a : visitedTypeVariables) -- now it's visited
              pure [tyToC b]
        (FuncTy argTysA retTyA _, FuncTy argTysB retTyB _) -> do
          visitedArgs <- fmap concat (zipWithM visit argTysA argTysB)
          visitedRets <- visit retTyA retTyB
          pure (visitedArgs ++ visitedRets)
        (StructTy _ a, StructTy _ b) -> fmap concat (zipWithM visit a b)
        (PointerTy a, PointerTy b) -> visit a b
        (RefTy a _, RefTy b _) -> visit a b
        (_, _) -> pure []

type VisitedTypes = [Ty]

-- | Templates are like macros, but defined inside the compiler and with access to the types they are instantiated with
data Template = Template
  { templateSignature :: Ty,
    templateDeclaration :: Ty -> [Token], -- Will this parameterization ever be useful?
    templateDefinition :: Ty -> [Token],
    templateDependencies :: Ty -> [XObj]
  }

instance Hashable Template where
  hashWithSalt s Template {..} = s `hashWithSalt` templateSignature

instance Show Template where
  show _ = "Template"

-- | Note: This is to make comparisons of Environments possible, otherwise
-- | they are always different when they contain Templates.
instance Eq Template where
  a == b = templateSignature a == templateSignature b

data TokTyMode = Normal | Raw deriving (Eq, Ord)

-- | Tokens are used for emitting C code from templates.
data Token
  = TokTy Ty TokTyMode -- Some kind of type, will be looked up if it's a type variable.
  | TokC String -- Plain C code.
  | TokDecl -- Will emit the declaration (i.e. "foo(int x)"), this is useful
  --   for avoiding repetition in the definition part of the template.
  | TokName -- Will emit the name of the instantiated function/variable.
  deriving (Eq, Ord)

instance Show Token where
  show (TokC s) = s
  show (TokTy t Normal) = tyToCLambdaFix t -- Any function type will be emitted as 'Lambda'
  show (TokTy t Raw) = tyToC t -- Function types will be emitted in typedef:able form
  show TokName = "<name>"
  show TokDecl = "<declaration>"

instantiateTemplate :: SymPath -> Ty -> Template -> (XObj, [XObj])
instantiateTemplate path actualType template =
  let defLst = [XObj (Instantiate template) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]
      deps = templateDependencies template actualType
   in (XObj (Lst defLst) (Just (Info (-1) (-1) (show path ++ " template") Set.empty (-1))) (Just actualType), deps)

-- | Type aliases are used to create C-typedefs when those are needed.
defineTypeAlias :: String -> Ty -> XObj
defineTypeAlias name t =
  XObj
    ( Lst
        [ XObj (Defalias t) Nothing Nothing,
          XObj (Sym (SymPath [] name) Symbol) Nothing Nothing
        ]
    )
    (Just dummyInfo)
    (Just TypeTy)

defineFunctionTypeAlias :: Ty -> XObj
defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy

defineArrayTypeAlias :: Ty -> XObj
defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) [])

defineStaticArrayTypeAlias :: Ty -> XObj
defineStaticArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) [])

-- |
defineInterface :: String -> Ty -> [SymPath] -> Maybe Info -> XObj
defineInterface name t paths info =
  XObj
    ( Lst
        [ XObj (Interface t paths) Nothing Nothing,
          XObj (Sym (SymPath [] name) Symbol) Nothing Nothing
        ]
    )
    info
    (Just InterfaceTy)

-- | Unsafe way of getting the type from an XObj
forceTy :: XObj -> Ty
forceTy xobj = fromMaybe (error ("No type in " ++ show xobj)) (xobjTy xobj)

-- | How should the compiler be run? Interactively or just build / build & run and then quit?
data ExecutionMode = Repl | Build | BuildAndRun | Install String | Check deriving (Show, Eq)

-- | Information needed by the REPL
data Context = Context
  { contextGlobalEnv :: Env,
    contextInternalEnv :: Maybe Env,
    contextTypeEnv :: TypeEnv,
    contextPath :: [String],
    contextProj :: Project,
    contextLastInput :: String,
    contextExecMode :: ExecutionMode,
    contextHistory :: ![XObj]
  }
  deriving (Show, Generic)

-- required for Hashable >= 1.4.0.0
instance Eq Context where
  c == c' =
    (contextGlobalEnv c) == (contextGlobalEnv c')
      && (contextInternalEnv c) == (contextInternalEnv c')
      && (contextTypeEnv c) == (contextTypeEnv c')

instance Hashable Context where
  hashWithSalt s Context {..} =
    s
      `hashWithSalt` contextGlobalEnv
      `hashWithSalt` contextInternalEnv
      `hashWithSalt` contextTypeEnv

popModulePath :: Context -> Context
popModulePath ctx = ctx {contextPath = init (contextPath ctx)}

pushFrame :: Context -> XObj -> Context
pushFrame ctx x = ctx {contextHistory = x : contextHistory ctx}

popFrame :: Context -> Context
popFrame ctx@Context {contextHistory = []} = ctx
popFrame ctx@Context {contextHistory = (_ : rest)} = ctx {contextHistory = rest}

-- | Unwrapping of XObj:s
-- | Unwrapping of XObj:s

-- | String
unwrapStringXObj :: XObj -> Either String String
unwrapStringXObj (XObj (Str s) _ _) = Right s
unwrapStringXObj x = Left ("The value '" ++ pretty x ++ "' at " ++ prettyInfoFromXObj x ++ " is not a String.")

-- | Bool
unwrapBoolXObj :: XObj -> Either String Bool
unwrapBoolXObj (XObj (Bol b) _ _) = Right b
unwrapBoolXObj x = Left ("The value '" ++ pretty x ++ "' at " ++ prettyInfoFromXObj x ++ " is not a Bool.")

-- | Symbol
unwrapSymPathXObj :: XObj -> Either String SymPath
unwrapSymPathXObj (XObj (Sym p _) _ _) = Right p
unwrapSymPathXObj x = Left ("The value '" ++ pretty x ++ "' at " ++ prettyInfoFromXObj x ++ " is not a Symbol.")

-- | Gives the name used to refer to a specific XObj (in emitted code)
varOfXObj :: XObj -> String
varOfXObj xobj =
  case xobj of
    XObj (Sym path _) _ _ -> pathToC path
    _ -> case xobjInfo xobj of
      Just i -> freshVar i
      Nothing -> error ("Missing info on " ++ show xobj)

-- | Given a form, what definition mode will it generate?
definitionMode :: XObj -> DefinitionMode
definitionMode (XObj (Lst (XObj Def _ _ : _)) _ _) = AVariable
definitionMode _ = AFunction

isGlobalVariableLookup :: SymbolMode -> Bool
isGlobalVariableLookup (LookupGlobal _ AVariable) = True
isGlobalVariableLookup _ = False

anonMemberNames :: [String]
anonMemberNames = map (\i -> "member" ++ show i) ([0 ..] :: [Int])

anonMemberSymbols :: [XObj]
anonMemberSymbols = map (\n -> XObj (Sym (SymPath [] n) Symbol) Nothing Nothing) anonMemberNames

-- | Calculate the name of a Sumtype tag
tagName :: Ty -> String -> String
tagName sumTy caseName =
  tyToC sumTy ++ "_" ++ mangle caseName ++ "_tag"

wrapInParens :: XObj -> XObj
wrapInParens xobj@(XObj (Lst _) _ _) =
  xobj -- already in parens
wrapInParens xobj@(XObj _ i t) =
  XObj (Lst [xobj]) i t

-- | Is this symbol name appropriate for a normal variable (i.e. NOT a type name or sumtype tag)
isVarName :: String -> Bool
isVarName (firstLetter : _) =
  not (isUpper firstLetter) -- This allows names beginning with special chars etc. to be OK for vars
isVarName _ = False

-- construct an empty list xobj
emptyList :: XObj
emptyList = XObj (Lst []) Nothing Nothing

wrapInRefTyIfMatchRef :: MatchMode -> Ty -> Ty
wrapInRefTyIfMatchRef MatchRef t = RefTy t (VarTy "whatever") -- TODO: Better name for the lifetime variable.
wrapInRefTyIfMatchRef MatchValue t = t

-- | Check if the Obj is static and resolvable
isResolvableStaticObj :: Obj -> Bool
isResolvableStaticObj Def = True
isResolvableStaticObj (Defn _) = True
isResolvableStaticObj (External _) = True
isResolvableStaticObj (Deftemplate _) = True
isResolvableStaticObj (Instantiate _) = True
isResolvableStaticObj (Fn _ _) = True
isResolvableStaticObj (Interface _ _) = True
isResolvableStaticObj Ref = True
isResolvableStaticObj _ = False

-- | Left biased semigroup instance for Envs.
instance Semigroup Env where
  e <> e' =
    let bindings = envBindings e
        bindings' = envBindings e'
        joinedParents =
          (envParent e >>= \p -> (pure p <|> (envParent e' >>= \p' -> pure (p <> p'))))
            <|> envParent e'
        joinedUseModules = envUseModules e <> envUseModules e'
     in e
          { envBindings = Map.union bindings bindings',
            envParent = joinedParents,
            envUseModules = joinedUseModules
          }

-- | Semigroup instance for Contexts
--   - Left biased in internal env combination
--   - Right biased in global env combination
--   - Right biased in type env combination
--  The assumption here is that the context on the LHS is the *older* context
--  in the case of conflicts, we prefer the bindings on the RHS *except* for
--  the internal environment, since retaining some bindings from the internal
--  env is typically the reason you'd call this function.
instance Semigroup Context where
  c <> c' =
    let global = contextGlobalEnv c
        global' = contextGlobalEnv c'
        internal = contextInternalEnv c
        internal' = contextInternalEnv c'
        typeEnv = getTypeEnv (contextTypeEnv c)
        typeEnv' = getTypeEnv (contextTypeEnv c')
     in c
          { contextGlobalEnv = global' <> global,
            contextInternalEnv = internal <> internal',
            contextTypeEnv = TypeEnv (typeEnv' <> typeEnv)
          }

toLocalDef :: String -> XObj -> XObj
toLocalDef var value =
  (XObj (Lst [XObj LocalDef Nothing Nothing, XObj (Sym (SymPath [] var) Symbol) Nothing Nothing, value]) (xobjInfo value) (xobjTy value))

-- | Create a fresh binder for an XObj (a binder with empty Metadata).
toBinder :: XObj -> Binder
toBinder xobj = Binder emptyMeta xobj

-- | Dynamic 'true'.
trueXObj :: XObj
trueXObj = XObj (Bol True) Nothing Nothing

-- | Dynamic 'false'.
falseXObj :: XObj
falseXObj = XObj (Bol False) Nothing Nothing

isList :: XObj -> Bool
isList (XObj (Lst _) _ _) = True
isList _ = False

-- | Applies an XObj transformation over all atomic XObjs in a form, retaining
-- list and array structure.
walk :: (XObj -> XObj) -> XObj -> XObj
walk f (XObj (Arr xs) i t) = XObj (Arr (map (walk f) xs)) i t
walk f (XObj (Lst xs) i t) = XObj (Lst (map (walk f) xs)) i t
walk f x = f x

wrapString :: String -> XObj
wrapString s = XObj (Str s) Nothing Nothing

wrapList :: [XObj] -> XObj
wrapList xs = XObj (Lst xs) Nothing Nothing

wrapArray :: [XObj] -> XObj
wrapArray xs = XObj (Arr xs) Nothing Nothing