-- "src/Dao/Interpreter/AST.hs"  defines the data types for the Dao
-- programming language abstract syntax tree and related type classes.
-- 
-- Copyright (C) 2008-2014  Ramin Honary.
-- This file is part of the Dao System.
--
-- The Dao System is free software: you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
-- 
-- The Dao System is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program (see the file called "LICENSE"). If not, see
-- <http://www.gnu.org/licenses/agpl.html>.

module Dao.Interpreter.AST
  ( Intermediate(toInterm, fromInterm), Canonical(canonicalize),
    Comment(InlineComment, EndlineComment),
    Com(Com, ComBefore, ComAfter, ComAround),
    NamespaceExpr(NamespaceExpr), AST_Namespace(AST_NoNamespace, AST_Namespace),
    setCommentBefore, setCommentAfter, unComment, getComment, 
    pPrintInterm, putAST, getAST, commentString, pPrintComWith,
    pListOfComsWith, pListOfComs, randComWith, appendComments, com,
    DotNameExpr(DotNameExpr), AST_DotName(AST_DotName), getDotNameAST, undotNameExpr,
    DotLabelExpr(DotLabelExpr), AST_DotLabel(AST_DotLabel), 
    dotLabelToNameList, dotLabelToRefExpr, refToDotLabelExpr, dotLabelToRefAST, refToDotLabelAST,
    RefSuffixExpr(NullRefExpr, DotRefExpr, SubscriptExpr, FuncCallExpr),
    ReferenceExpr(ReferenceExpr, RefObjectExpr),
    RefPfxOp(REF, DEREF), 
    RefQualifier(UNQUAL, LOCAL, CONST, STATIC, GLOBAL, GLODOT),
    UpdateOp(UCONST, UADD, USUB, UMULT, UDIV, UMOD, UPOW, UORB, UANDB, UXORB, USHL, USHR), 
    ArithPfxOp(INVB, NOT, NEGTIV, POSTIV), 
    InfixOp(
      ADD, SUB, MULT, DIV, MOD, POW, ORB, ANDB, XORB, SHL, SHR, OR, AND,
      EQUL, NEQUL, GTN, LTN, GTEQ, LTEQ, ARROW
    ), infixOpCommutativity,
    allUpdateOpStrs, allPrefixOpChars, allPrefixOpStrs, allInfixOpChars, allInfixOpStrs,
    AST_RefSuffix(AST_RefNull, AST_DotRef, AST_Subscript, AST_FuncCall),
    AST_Reference(AST_Reference, AST_RefObject),
    ObjListExpr(ObjListExpr), AST_ObjList(AST_ObjList),
    OptObjListExpr(OptObjListExpr), AST_OptObjList(AST_OptObjList),
    LiteralExpr(LiteralExpr), AST_Literal(AST_Literal),
    ParenExpr(ParenExpr), AST_Paren(AST_Paren), 
    AssignExpr(EvalExpr, AssignExpr), AST_Assign(AST_Eval, AST_Assign),
    ObjTestExpr(ObjArithExpr, ObjTestExpr, ObjRuleFuncExpr),
    AST_ObjTest(AST_ObjArith, AST_ObjTest, AST_ObjRuleFunc),
    ArithExpr(ObjectExpr, ArithExpr), AST_Arith(AST_Object, AST_Arith), 
    RuleFuncExpr(LambdaExpr, FuncExpr, RuleExpr), AST_RuleFunc(AST_Lambda, AST_Func, AST_Rule),
    TyChkExpr(NotTypeChecked, TypeChecked, DisableCheck), fmapCheckedValueExpr,
    tyChkItem, tyChkExpr, tyChkLoc, typChkResult, checkedExpr,
    AST_TyChk(AST_NotChecked, AST_Checked), checkedAST, fmapCheckedValueAST,
    ParamExpr(ParamExpr), AST_Param(AST_NoParams, AST_Param), 
    ParamListExpr(ParamListExpr), getTypeCheckList,
    AST_ParamList(AST_ParamList), 
    RuleHeadExpr(RuleStringExpr, RuleHeadExpr), 
    AST_RuleHeader(AST_NullRules, AST_RuleString, AST_RuleHeader), 
    CodeBlock(CodeBlock), codeBlock,
    AST_CodeBlock(AST_CodeBlock), getAST_CodeBlock, 
    RefPrefixExpr(PlainRefExpr, RefPrefixExpr), cleanupRefPrefixExpr,
    AST_RefPrefix(AST_RefPrefix, AST_PlainRef),
    ObjectExpr(
      VoidExpr, ObjLiteralExpr, ObjSingleExpr,
      ArithPfxExpr, InitExpr, StructExpr, MetaEvalExpr
    ),
    AST_Object(
      AST_Void, AST_ObjLiteral, AST_ObjSingle,
      AST_ArithPfx, AST_Init, AST_Struct, AST_MetaEval
    ),
    ScriptExpr(
      IfThenElse, WhileLoop, RuleFuncExpr, EvalObject,
      TryCatch, ForLoop, ContinueExpr, ReturnExpr, WithDoc
    ),
    IfExpr(IfExpr), AST_If(AST_If), 
    ElseExpr(ElseExpr), AST_Else(AST_Else), 
    IfElseExpr(IfElseExpr), AST_IfElse(AST_IfElse), 
    LastElseExpr(LastElseExpr), AST_LastElse(AST_LastElse),
    CatchExpr(CatchExpr), AST_Catch(AST_Catch),
    WhileExpr(WhileExpr), AST_While(AST_While), 
    AST_Script(
      AST_Comment, AST_IfThenElse, AST_WhileLoop, AST_RuleFunc, AST_EvalObject,
      AST_TryCatch, AST_ForLoop, AST_ContinueExpr, AST_ReturnExpr, AST_WithDoc
    ),
    TopLevelEventType(BeginExprType, EndExprType, ExitExprType), 
    TopLevelExpr(RequireExpr, ImportExpr, TopScript, EventExpr), isAttribute, 
    AST_TopLevel(AST_Require, AST_Import, AST_TopScript, AST_Event, AST_TopComment),
    isAST_Attribute, getRequiresAndImports,
    AttributeExpr(AttribDotNameExpr, AttribStringExpr),
    AST_Attribute(AST_AttribDotName, AST_AttribString),
    Program(Program), topLevelExprs,
    AST_SourceCode(AST_SourceCode), sourceModified, sourceFullPath, directives, 
  )
  where

import qualified Dao.Binary  as B
import           Dao.String
import           Dao.PPrint
import           Dao.Random
import           Dao.Token

import           Data.Array.IArray
import           Data.List (intersperse)
import           Data.Monoid
import           Data.Typeable
import           Data.Word

import           Control.Applicative
import           Control.DeepSeq
import           Control.Monad

----------------------------------------------------------------------------------------------------

-- | Elements of the symantic data structures that instantiate 'Executable' and do not instantiate
-- 'Dao.PPrint.PPrintable', 'Dao.Struct.Structured', or any parsers. Elements of the abstract syntax
-- tree (AST) instantiate 'Dao.PPrint.PPrintable', 'Dao.Struct.Structured', and all of the parsers,
-- but are not executable and do not instantiate 'Executable'. This separates concerns pretty well,
-- but leaves us with the problem of having to convert back and forth between these various data
-- types.
--
-- The 'Intermediate' class allows us to declare a one-to-one relationship between AST types and
-- executable types. For example, 'ObjectExpr' is the intermediate representation of
-- 'AST_Object', so our instance for this relationship is @instane 'Intermediate'
-- 'ObjectExpr' 'AST_Object'@.
class Intermediate obj ast | obj -> ast, ast -> obj where
  toInterm   :: ast -> [obj]
  fromInterm :: obj -> [ast]

-- | This class is used to classify data types that can be generated at random by
-- 'Dao.Random.HasRandGen' and parsed from source code, which might generate data types with
-- identical functionality, identical pretty-printed forms, identical 'Executable' semantics but may
-- have differences in the recursive structure that the 'Prelude.Eq' class would compute as not
-- identical. The job of the 'canonicalize' function is to eliminate these discrepancies by reducing
-- the data structure to a canonical form.
class Canonical a where { canonicalize :: a -> a }

instance Intermediate Name Name where { toInterm = return; fromInterm = return; }

-- Not for export: here are a bunch of shortcuts to converting the AST to the intermediate data
-- type. Sinec 'toInterm' returns a single item in a list to indicate success and an empty list to
-- indicate failure, all of these items have their evaluated type wrapped in a list type. This is to
-- allow the 'toInterm' instances use the 'Control.Monad.liftM' family of functions.
ti :: Intermediate obj ast => ast -> [obj]
ti = toInterm
uc :: Com a -> [a]
uc = return . unComment
uc0 :: Intermediate obj ast =>  Com ast  -> [obj]
uc0 = toInterm . unComment
um1 :: Intermediate obj ast => Maybe ast -> [Maybe obj]
um1 = maybe [Nothing] (fmap Just . toInterm)

fi :: Intermediate obj ast => obj -> [ast]
fi = fromInterm
nc :: a -> [Com a]
nc = return . Com
nc0 :: Intermediate obj ast => obj -> [Com ast]
nc0 = fmap Com . fromInterm
nm1 :: Intermediate obj ast => Maybe obj -> [Maybe ast]
nm1 = maybe [Nothing] (fmap Just . fromInterm)

-- not for export
no :: RandO Location
no = return LocationUnknown

-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type
-- that is pretty-printable ('Dao.PPrint.PPrintable').
pPrintInterm :: (Intermediate o ast, PPrintable ast) => o -> PPrint
pPrintInterm = mapM_ pPrint . fromInterm

-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type
-- that is 'Dao.Binary.GPut'.
putAST :: (Intermediate obj ast, B.Binary obj mtab) => ast -> B.GPut mtab
putAST ast = case toInterm ast of
    [obj] -> B.put obj
    _     -> fail "binary encoder could not convert AST to intermediate expression"

-- | If there is a type that instantiates 'Intermediate', it can be converted to and from a type
-- that is 'Dao.Binary.GGet'.
getAST :: (Intermediate obj ast, B.Binary obj mtab) => B.GGet mtab ast
getAST = B.get >>= \obj -> case fromInterm obj of
    [ast] -> return ast
    _     -> fail "binary decoder constructed object that could not be converted to an AST representation"

----------------------------------------------------------------------------------------------------

-- | Comments in the Dao language are not interpreted, but they are not disgarded either. Dao is
-- intended to manipulate natural language, and itself, so that it can "learn" new semantic
-- structures. Dao scripts can manipulate the syntax tree of other Dao scripts, and so it might be
-- helpful if the syntax tree included comments.
data Comment
  = InlineComment  UStr
  | EndlineComment UStr
  deriving (Eq, Ord, Typeable, Show)

commentString :: Comment -> UStr
commentString com = case com of
  InlineComment  a -> a
  EndlineComment a -> a

instance NFData Comment where
  rnf (InlineComment  a) = seq a ()
  rnf (EndlineComment a) = seq a ()

instance HasNullValue Comment where
  nullValue = EndlineComment nil
  testNull (EndlineComment c) = c==nil
  testNull (InlineComment  c) = c==nil

instance PPrintable Comment where
  pPrint com = do
    case com of
      EndlineComment c -> pString ("//"++uchars c) >> pForceNewLine
      InlineComment  c -> pGroup True $ pInline $
        concat [[pString " /*"], map pString (lines (uchars c)), [pString "*/ "]]

instance PrecedeWithSpace a => PrecedeWithSpace (Com a) where
  precedeWithSpace o = case o of
    Com         b   -> precedeWithSpace b
    ComBefore a b   -> precedeWithSpace a || precedeWithSpace b
    ComAfter    b _ -> precedeWithSpace b
    ComAround a b _ -> precedeWithSpace a || precedeWithSpace b
    -- there should always be a space before a comment.

instance PPrintable [Comment] where { pPrint = mapM_ pPrint }

instance PrecedeWithSpace [Comment] where { precedeWithSpace = not . null }

instance HasRandGen [Comment] where { randO = return []; defaultO = return []; }
--  randO = do
--    i0 <- randInt
--    let (i1, many) = divMod i0 4
--        (i2, typn) = divMod i1 16
--        typx = take many (randToBase 2 typn ++ replicate 4 0)
--        lenx = map (+1) (randToBase 29 i2)
--        com typ = if typ==0 then EndlineComment else InlineComment
--    forM (zip typx lenx) $ \ (typ, len) ->
--      fmap (com typ . ustr . unwords . map (B.unpack . getRandomWord)) (replicateM len randInt)

----------------------------------------------------------------------------------------------------

-- | Symbols in the Dao syntax tree that can actually be manipulated can be surrounded by comments.
-- The 'Com' structure represents a space-efficient means to surround each syntactic element with
-- comments that can be ignored without disgarding them.
data Com a = Com a | ComBefore [Comment] a | ComAfter a [Comment] | ComAround [Comment] a [Comment]
  deriving (Eq, Ord, Typeable, Show)

instance Functor Com where
  fmap fn c = case c of
    Com          a    -> Com          (fn a)
    ComBefore c1 a    -> ComBefore c1 (fn a)
    ComAfter     a c2 -> ComAfter     (fn a) c2
    ComAround c1 a c2 -> ComAround c1 (fn a) c2

instance NFData a => NFData (Com a) where
  rnf (Com         a  ) = deepseq a ()
  rnf (ComBefore a b  ) = deepseq a $! deepseq b ()
  rnf (ComAfter    a b) = deepseq a $! deepseq b ()
  rnf (ComAround a b c) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue a => HasNullValue (Com a) where
  nullValue = Com nullValue
  testNull (Com a) = testNull a
  testNull _ = False

instance HasLocation a => HasLocation (Com a) where
  getLocation = getLocation . unComment
  setLocation com loc = fmap (\a -> setLocation a loc) com
  delLocation = fmap delLocation

instance HasRandGen a => HasRandGen (Com a) where
  randO    = Com <$> randO
  defaultO = Com <$> defaultO

instance PPrintable a => PPrintable (Com a) where { pPrint = pPrintComWith pPrint }

pPrintComWith :: (a -> PPrint) -> Com a -> PPrint
pPrintComWith prin com = case com of
  Com          c    -> prin c
  ComBefore ax c    -> pcom ax >> prin c
  ComAfter     c bx -> prin c >> pcom bx
  ComAround ax c bx -> pcom ax >> prin c >> pcom bx
  where { pcom = pInline . map pPrint }

pListOfComsWith :: (a -> PPrint) -> [Com a] -> PPrint
pListOfComsWith prin = sequence_ . map (pPrintComWith prin)

pListOfComs :: PPrintable a => [Com a] -> PPrint
pListOfComs = pListOfComsWith pPrint

randComWith :: RandO a -> RandO (Com a)
randComWith rand = fmap Com rand
--  randComWith :: RandO a -> RandO (Com a)
--  randComWith rand = do
--    typ <- fmap (flip mod 24 . unsign) randInt
--    a <- rand
--    case typ of
--      0 -> do
--        before <- randO
--        after  <- randO
--        return (ComAround before a after)
--      1 -> do
--        before <- randO
--        return (ComBefore before a)
--      2 -> do
--        after <- randO
--        return (ComAfter a after)
--      _ -> return (Com a)

appendComments :: Com a -> [Comment] -> Com a
appendComments com cx = case com of
  Com          a    -> ComAfter     a cx
  ComAfter     a ax -> ComAfter     a (ax++cx)
  ComBefore ax a    -> ComAround ax a cx
  ComAround ax a bx -> ComAround ax a (bx++cx)

com :: [Comment] -> a -> [Comment] -> Com a
com before a after = case before of
  [] -> case after of
    [] -> Com a
    dx -> ComAfter a dx
  cx -> case after of
    [] -> ComBefore cx a
    dx -> ComAround cx a dx

setCommentBefore :: [Comment] -> Com a -> Com a
setCommentBefore cx com = case com of
  Com         a    -> ComBefore cx a
  ComBefore _ a    -> ComBefore cx a
  ComAfter    a dx -> ComAround cx a dx
  ComAround _ a dx -> ComAround cx a dx

setCommentAfter :: [Comment] -> Com a -> Com a
setCommentAfter cx com = case com of
  Com          a   -> ComAfter     a cx
  ComBefore dx a   -> ComAround dx a cx
  ComAfter     a _ -> ComAfter     a cx
  ComAround dx a _ -> ComAround dx a cx

unComment :: Com a -> a
unComment com = case com of
  Com         a   -> a
  ComBefore _ a   -> a
  ComAfter    a _ -> a
  ComAround _ a _ -> a

getComment :: Com a -> ([Comment], [Comment])
getComment com = case com of
  Com         _   -> ([], [])
  ComBefore a _   -> (a, [])
  ComAfter    _ b -> ([], b)
  ComAround a _ b -> (a, b)

----------------------------------------------------------------------------------------------------

-- | Direct a reference at a particular tree in the runtime.
data RefQualifier
  = UNQUAL -- ^ unqualified
  | LOCAL  -- ^ refers to the current local variable stack
  | CONST  -- ^ refers to a built-in constant
  | STATIC -- ^ a local variable stack specific to a 'Subroutine' that lives on even after the
           -- subroutine has completed.
  | GLOBAL -- ^ the global variable space for the current module.
  | GLODOT -- ^ a relative reference, gets it's name because it begins with a dot (".") character.
           -- Similar to the "this" keyword in C++ and Java, refers to the object of the current
           -- context set by the "with" statement, but defaults to the global variable space when
           -- not within a "with" statement. This is necessary to differentiate between local
           -- variables and references to the "with" context.
  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)

instance NFData RefQualifier where { rnf a = seq a () }

instance PPrintable RefQualifier where { pPrint = pUStr . toUStr }

instance PrecedeWithSpace RefQualifier where
   precedeWithSpace o = case o of
     LOCAL  -> True
     CONST  -> True
     STATIC -> True
     GLOBAL -> True
     _      -> False

instance UStrType RefQualifier where
  toUStr a = ustr $ case a of
    UNQUAL -> ""
    LOCAL  -> "local"
    CONST  -> "const"
    STATIC -> "static"
    GLOBAL -> "global"
    GLODOT -> "."
  maybeFromUStr str = case uchars str of
    "local"  -> Just LOCAL
    "const"  -> Just CONST
    "static" -> Just STATIC
    "global" -> Just GLOBAL
    "."      -> Just GLODOT
    ""       -> Just UNQUAL
    _        -> Nothing
  fromUStr str = maybe (error (show str++" is not a reference qualifier")) id (maybeFromUStr str)

instance HasRandGen RefQualifier where
  randO = fmap toEnum (nextInt (1+fromEnum (minBound::RefQualifier)))
  defaultO = randO

----------------------------------------------------------------------------------------------------

-- | Binary operators.
data InfixOp
  = ADD   | SUB   | MULT
  | DIV   | MOD   | POW
  | ORB   | ANDB  | XORB
  | SHL   | SHR
  | OR    | AND
  | EQUL  | NEQUL      
  | GTN   | LTN
  | GTEQ  | LTEQ
  | ARROW
  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)

instance UStrType InfixOp where
  toUStr a = ustr $ case a of
    { ADD  -> "+" ; SUB  -> "-" ; MULT  -> "*"
    ; DIV  -> "/" ; MOD  -> "%" ; POW   -> "**"
    ; ORB  -> "|" ; ANDB -> "&" ; XORB  -> "^"
    ; SHL  -> "<<"; SHR  -> ">>"
    ; OR   -> "||"; AND  -> "&&"
    ; EQUL -> "=="; NEQUL-> "!="
    ; LTN  -> "<" ; GTN  -> ">"
    ; LTEQ -> "<="; GTEQ -> ">="
    ; ARROW -> "->";
    }
  maybeFromUStr str = case uchars str of
    { "+"  -> Just ADD  ; "-"  -> Just SUB  ; "*"  -> Just MULT 
    ; "/"  -> Just DIV  ; "%"  -> Just MOD  ; "**" -> Just POW  
    ; "|"  -> Just ORB  ; "&"  -> Just ANDB ; "^"  -> Just XORB 
    ; "<<" -> Just SHL  ; ">>" -> Just SHR
    ; "||" -> Just OR   ; "&&" -> Just AND
    ; "==" -> Just EQUL ; "!=" -> Just NEQUL
    ; "<"  -> Just LTN  ; ">"  -> Just GTN
    ; "<=" -> Just LTEQ ; ">=" -> Just GTEQ 
    ; "->" -> Just ARROW;
    ; _    -> Nothing
    }
  fromUStr str = maybe (error (show str++" is not an infix operator")) id (maybeFromUStr str)

instance NFData InfixOp  where { rnf a = seq a () }

instance PPrintable InfixOp  where { pPrint = pUStr . toUStr }

infixOpCommutativity :: InfixOp -> Bool
infixOpCommutativity = (arr !) where
  arr :: Array InfixOp Bool
  arr = array (minBound, maxBound) $
    [ (ADD, True), (SUB, False), (MULT, True), (DIV, False), (MOD, False), (POW, False)
    , (ORB, True), (ANDB, True), (XORB, True), (SHL, False), (SHR, False), (OR, False), (AND, False)
    , (EQUL, True), (NEQUL, True), (LTN, False), (GTN, False), (LTEQ, False), (GTEQ, False)
    , (ARROW, False)
    ]

-- binary 0x8D 0xA0
instance B.Binary InfixOp mtab where
  put o = B.putWord8 $ case o of
    { EQUL -> 0x8D; NEQUL -> 0x8E; GTN  -> 0x8F; LTN   -> 0x90; GTEQ -> 0x91; LTEQ -> 0x92
    ; ADD  -> 0x93; SUB   -> 0x94; MULT -> 0x95; DIV   -> 0x96
    ; MOD  -> 0x97; POW   -> 0x98; ORB  -> 0x99; ANDB  -> 0x9A
    ; XORB -> 0x9B; SHL   -> 0x9C; SHR  -> 0x9D; ARROW -> 0x9E
    ; OR   -> 0x9F; AND   -> 0xA0 } 
  get = B.word8PrefixTable <|> fail "expecting InfixOp"

-- The byte prefixes overlap with the update operators of similar function to
-- the operators, except for the comparison opeators (EQUL, NEQUL, GTN, LTN,
-- GTEQ, LTEQ) which overlap with the prefix operators (INVB, NOT, NEGTIV, POSTIV, REF, DEREF)
instance B.HasPrefixTable InfixOp B.Byte mtab where
  prefixTable = B.mkPrefixTableWord8 "InfixOp" 0x8D 0xA0 $ let {r=return} in
    [ r EQUL , r NEQUL, r GTN , r LTN, r GTEQ , r LTEQ -- 0x8D,0x8E,0x8F,0x90,0x91,0x92
    , r ADD  , r SUB  , r MULT, r DIV, r MOD  , r POW  , r ORB -- 0x93,0x94,0x95,0x96,0x97,0x98,0x99
    , r ANDB , r XORB , r SHL , r SHR, r ARROW, r OR   , r AND -- 0x9A,0x9B,0x9C,0x9D,0x9E,0x9F,0xA0
    ]

instance HasRandGen InfixOp where
  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::InfixOp)))
  defaultO = randO

allPrefixOpChars :: String
allPrefixOpChars = "$@~!-+"

allPrefixOpStrs :: String
allPrefixOpStrs = " $ @ ~ - + ! "

----------------------------------------------------------------------------------------------------

-- | Unary operators.
data ArithPfxOp = INVB | NOT | NEGTIV | POSTIV
  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)

instance NFData ArithPfxOp where { rnf a = seq a () }

instance UStrType ArithPfxOp where
  toUStr op = ustr $ case op of
    INVB   -> "~"
    NOT    -> "!"
    NEGTIV -> "-"
    POSTIV -> "+"
  maybeFromUStr str = case uchars str of
    "~" -> Just INVB
    "!" -> Just NOT
    "-" -> Just NEGTIV
    "+" -> Just POSTIV
    _   -> Nothing
  fromUStr str = maybe (error (show str++" is not a prefix opretor")) id (maybeFromUStr str)

instance PPrintable ArithPfxOp where { pPrint = pUStr . toUStr }

-- binary 0x8E 0x9B
instance B.Binary ArithPfxOp mtab where
  put o = B.putWord8 $ case o of { INVB -> 0x9B; NOT -> 0x8E; NEGTIV -> 0x94; POSTIV -> 0x93 }
  get = B.word8PrefixTable <|> fail "expecting ArithPfxOp"

instance B.HasPrefixTable ArithPfxOp B.Byte mtab where
  prefixTable = B.mkPrefixTableWord8 "ArithPfxOp" 0x8E 0x9F $ let {r=return;z=mzero} in
    [ r NOT -- 0x8E
    , z, z, z, z -- 0x8F,0x90,0x91,0x92
    , r POSTIV, r NEGTIV -- 0x93,0x94
    , z, z, z, z, z, z -- 0x95,0x96,0x97,0x98,0x99,0x9A
    , r INVB -- 0x9B
    ]

instance HasRandGen ArithPfxOp where
  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::ArithPfxOp)))
  defaultO = randO

allInfixOpChars :: String
allInfixOpChars = "+-*/%<>^&|.?:"

allInfixOpStrs :: String
allInfixOpStrs = " + - * / % ** -> . || && == != | & ^ << >> < > <= >= . -> <- ? : :: "

----------------------------------------------------------------------------------------------------

newtype DotNameExpr = DotNameExpr{ undotNameExpr :: Name } deriving (Eq, Ord, Show, Typeable)

instance NFData DotNameExpr where { rnf (DotNameExpr n) = deepseq n () }

instance B.Binary DotNameExpr mtab where { put (DotNameExpr n) = B.put n; get = DotNameExpr <$> B.get; }

instance PPrintable DotNameExpr where { pPrint (DotNameExpr n) = pPrint n }

-- | A 'DotName' is simply a ".name" expression in the Dao language. It is a component of the
-- 'DotLabelExpr' and 'AST_DotLabel' data types.
data AST_DotName = AST_DotName (Com ()) Name deriving (Eq, Ord, Show, Typeable)

getDotNameAST :: AST_DotName -> Name
getDotNameAST (AST_DotName _ n) = n

instance NFData AST_DotName where { rnf (AST_DotName a b) = deepseq a $! deepseq b () }

instance PPrintable AST_DotName where
  pPrint (AST_DotName c n) = pInline [pPrintComWith (\ () -> pString ".") c, pPrint n]

instance Intermediate DotNameExpr AST_DotName where
  toInterm   (AST_DotName _ n) = [DotNameExpr n]
  fromInterm (DotNameExpr   n) = [AST_DotName (Com ()) n]

----------------------------------------------------------------------------------------------------

data NamespaceExpr = NamespaceExpr (Maybe Name) Location deriving (Eq, Ord, Show, Typeable)

instance NFData NamespaceExpr where { rnf (NamespaceExpr a b) = deepseq a $! deepseq b () }

instance HasNullValue NamespaceExpr where
  nullValue = NamespaceExpr Nothing LocationUnknown
  testNull (NamespaceExpr Nothing _) = True
  testNull _ = False

instance HasLocation NamespaceExpr where
  getLocation (NamespaceExpr _ loc)     = loc
  setLocation (NamespaceExpr a _  ) loc = NamespaceExpr a loc
  delLocation (NamespaceExpr a _  )     = NamespaceExpr a LocationUnknown

instance PPrintable NamespaceExpr where { pPrint = pPrintInterm }

instance B.Binary NamespaceExpr mtab where
  put (NamespaceExpr a loc) = B.put a >> B.put loc
  get = return NamespaceExpr <*> B.get <*> B.get

----------------------------------------------------------------------------------------------------

data AST_Namespace
  = AST_NoNamespace
  | AST_Namespace (Com Name) Location
  deriving (Eq, Ord, Show, Typeable)

instance NFData AST_Namespace where
  rnf  AST_NoNamespace    = ()
  rnf (AST_Namespace a b) = deepseq a $! deepseq b ()

instance HasNullValue AST_Namespace where
  nullValue = AST_NoNamespace
  testNull AST_NoNamespace = True
  testNull _ = False

instance HasLocation AST_Namespace where
  getLocation o     = case o of
    AST_NoNamespace     -> LocationUnknown
    AST_Namespace _ loc -> loc
  setLocation o loc = case o of
    AST_NoNamespace     -> AST_NoNamespace
    AST_Namespace a _   -> AST_Namespace a loc
  delLocation o     = case o of
    AST_NoNamespace     -> AST_NoNamespace
    AST_Namespace a _   -> AST_Namespace a LocationUnknown

instance PPrintable AST_Namespace where
  pPrint o = case o of { AST_NoNamespace -> return (); AST_Namespace a _ -> pPrint a; }

instance HasRandGen AST_Namespace where
  randO = countNode $ runRandChoice
  randChoice = randChoiceList [return AST_NoNamespace, return AST_Namespace <*> randO <*> no]
  defaultO = randO
  defaultChoice = randChoiceList [defaultO]

instance Intermediate NamespaceExpr AST_Namespace where
  toInterm o = case o of
    AST_NoNamespace     -> [nullValue]
    AST_Namespace n loc -> [NamespaceExpr (Just $ unComment n) loc]
  fromInterm (NamespaceExpr n loc) = case n of
    Nothing -> [nullValue]
    Just  n -> [AST_Namespace (Com n) loc]

----------------------------------------------------------------------------------------------------

-- | The intermediate form of 'AST_DotLabel'.
data DotLabelExpr = DotLabelExpr DotNameExpr [DotNameExpr] Location 
  deriving (Eq, Ord, Show, Typeable)

instance NFData DotLabelExpr where
  rnf (DotLabelExpr n nm loc) = deepseq n $! deepseq nm $! deepseq loc ()

instance HasLocation DotLabelExpr where
  getLocation (DotLabelExpr _ _  loc)     = loc
  setLocation (DotLabelExpr n nx _  ) loc = DotLabelExpr n nx loc
  delLocation (DotLabelExpr n nx _  )     = DotLabelExpr n nx LocationUnknown

instance B.Binary DotLabelExpr mtab where
  put (DotLabelExpr n nx loc) = B.prefixByte 0x81 $ B.put n >> B.put nx >> B.put loc
  get = B.word8PrefixTable <|> fail "expecting DotLabelExpr"

instance B.HasPrefixTable DotLabelExpr Word8 mtab where
  prefixTable = B.mkPrefixTableWord8 "DotLabelExpr" 0x81 0x81 $
    [return DotLabelExpr <*> B.get <*> B.get <*> B.get]

instance PPrintable DotLabelExpr where { pPrint = pPrintInterm }

dotLabelToNameList :: DotLabelExpr -> [Name]
dotLabelToNameList (DotLabelExpr n nx _) = map undotNameExpr (n:nx)

----------------------------------------------------------------------------------------------------

-- | This is a list of 'Dao.String.Name's separated by dots. It is a pseudo-reference used to denote
-- things like constructor names in 'InitExpr', or setting the logical names of "import" modules
-- statements. It is basically a list of 'Dao.String.Name's that always has at least one element.
data AST_DotLabel = AST_DotLabel Name [AST_DotName] Location deriving (Eq, Ord, Show, Typeable)

instance NFData AST_DotLabel where
  rnf (AST_DotLabel n nx loc) = deepseq n $! deepseq nx $! deepseq loc ()

instance HasLocation AST_DotLabel where
  getLocation (AST_DotLabel _ _  loc)     = loc
  setLocation (AST_DotLabel n nx _  ) loc = AST_DotLabel n nx loc
  delLocation (AST_DotLabel n nx _  )     = AST_DotLabel n nx LocationUnknown

instance PPrintable AST_DotLabel where
  pPrint (AST_DotLabel n nx _) = pWrapIndent $ pPrint n : map pPrint nx

instance HasRandGen AST_DotLabel where
  randO = return AST_DotLabel <*> randO <*> randListOf 0 3 (return AST_DotName <*> randO <*> randO) <*> no
  defaultO = randO

instance Intermediate DotLabelExpr AST_DotLabel where
  toInterm   (AST_DotLabel              n  nx loc) = [DotLabelExpr] <*> [DotNameExpr n] <*> [nx >>= ti] <*> [loc]
  fromInterm (DotLabelExpr (DotNameExpr n) nx loc) = [AST_DotLabel] <*>             [n] <*> [nx >>= fi] <*> [loc]

dotLabelToRefExpr :: DotLabelExpr -> ReferenceExpr o
dotLabelToRefExpr (DotLabelExpr (DotNameExpr n) nx loc) =
  ReferenceExpr UNQUAL n (loop nx) loc where
    loop nx = case nx of
      []                 -> NullRefExpr
      (DotNameExpr n):nx -> DotRefExpr n (loop nx) LocationUnknown

refToDotLabelExpr :: ReferenceExpr o -> Maybe (DotLabelExpr, Maybe (ObjListExpr o))
refToDotLabelExpr o = case o of
  ReferenceExpr UNQUAL n suf loc ->
    loop (\nx loc ol -> (DotLabelExpr (DotNameExpr n) nx loc, ol)) [] loc suf
  _ -> mzero
  where
    loop f nx loc suf = case suf of
      NullRefExpr                 -> return (f nx loc Nothing)
      DotRefExpr   n  suf    loc' -> loop f (nx++[DotNameExpr n]) (loc<>loc') suf
      FuncCallExpr ol NullRefExpr -> return (f nx loc (Just ol))
      _                           -> mzero

dotLabelToRefAST :: AST_DotLabel -> AST_Reference o
dotLabelToRefAST (AST_DotLabel n nx loc) = AST_Reference UNQUAL [] n (loop nx) loc where
  loop nx = case nx of
    []                   -> AST_RefNull
    (AST_DotName c n):nx -> AST_DotRef c n (loop nx) LocationUnknown

refToDotLabelAST :: AST_Reference o -> Maybe (AST_DotLabel, Maybe (AST_ObjList o))
refToDotLabelAST o = case o of
  AST_Reference UNQUAL _ n suf loc -> loop (\nx loc ol -> (AST_DotLabel n nx loc, ol)) [] loc suf
  _                                -> mzero
  where
    loop f nx loc suf = case suf of
      AST_RefNull                 -> return (f nx loc Nothing)
      AST_DotRef c n  suf    loc' -> loop f (nx++[AST_DotName c n]) (loc<>loc') suf
      AST_FuncCall ol AST_RefNull -> return (f nx loc (Just ol))
      _                           -> mzero

----------------------------------------------------------------------------------------------------

data RefSuffixExpr o
  = NullRefExpr
  | DotRefExpr    Name        (RefSuffixExpr o) Location
  | SubscriptExpr (ObjListExpr o) (RefSuffixExpr o)
  | FuncCallExpr  (ObjListExpr o) (RefSuffixExpr o)
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (RefSuffixExpr o) where
  rnf  NullRefExpr          = ()
  rnf (DotRefExpr    a b c) = deepseq a $! deepseq b $! deepseq c ()
  rnf (SubscriptExpr a b  ) = deepseq a $! deepseq b ()
  rnf (FuncCallExpr  a b  ) = deepseq a $! deepseq b ()

instance HasNullValue (RefSuffixExpr o) where
  nullValue = NullRefExpr
  testNull NullRefExpr = True
  testNull _           = False

instance HasLocation (RefSuffixExpr o) where
  getLocation o = case o of
    NullRefExpr           -> LocationUnknown
    DotRefExpr    _ _ loc -> loc
    SubscriptExpr a _     -> getLocation a
    FuncCallExpr  a _     -> getLocation a
  setLocation o loc = case o of
    NullRefExpr           -> NullRefExpr
    DotRefExpr    a b _   -> DotRefExpr    a b loc
    SubscriptExpr a b     -> SubscriptExpr (setLocation a loc) b
    FuncCallExpr  a b     -> FuncCallExpr  (setLocation a loc) b
  delLocation o     = case o of
    NullRefExpr           -> NullRefExpr
    DotRefExpr    a b _   -> DotRefExpr    a (delLocation b) LocationUnknown
    SubscriptExpr a b     -> SubscriptExpr a (delLocation b)
    FuncCallExpr  a b     -> FuncCallExpr  a (delLocation b)

----------------------------------------------------------------------------------------------------

-- | Anything that follows a reference, which could be square-bracketed indecies, function
-- parameters, or a dot and another reference. This is actually only a partial reference. The
-- 'Reference' is the full reference. The item selected by the 'Reference' is then further inspected
-- using a 'RefSuffix'; a 'RefSuffix' may be null, but a 'Reference' is never null.
data AST_RefSuffix o
  = AST_RefNull
  | AST_DotRef    (Com ()) Name (AST_RefSuffix o) Location
  | AST_Subscript (AST_ObjList o)   (AST_RefSuffix o)
  | AST_FuncCall  (AST_ObjList o)   (AST_RefSuffix o)
  deriving (Eq, Ord, Typeable, Show, Functor)

instance HasNullValue (AST_RefSuffix o) where
  nullValue = AST_RefNull
  testNull AST_RefNull = True
  testNull _ = False

instance HasLocation (AST_RefSuffix o) where
  getLocation o     = case o of
    AST_RefNull             -> LocationUnknown
    AST_DotRef    _ _ _ loc -> loc
    AST_Subscript a _       -> getLocation a
    AST_FuncCall  a _       -> getLocation a
  setLocation o loc = case o of
    AST_RefNull           -> AST_RefNull
    AST_DotRef    a b c _ -> AST_DotRef  a b c loc
    AST_Subscript a b     -> AST_Subscript (setLocation a loc) b
    AST_FuncCall  a b     -> AST_FuncCall  (setLocation a loc) b
  delLocation o     = case o of
    AST_RefNull           -> AST_RefNull
    AST_DotRef    a b c _ -> AST_DotRef  a b (delLocation c) LocationUnknown
    AST_Subscript a b     -> AST_Subscript (delLocation a) (delLocation b)
    AST_FuncCall  a b     -> AST_FuncCall  (delLocation a) (delLocation b)

instance PPrintable o => PPrintable (AST_RefSuffix o) where
  pPrint = pWrapIndent . loop where
    loop ref = case ref of
      AST_RefNull                  -> []
      AST_DotRef    dot name ref _ -> pPrintComWith (\ () -> pString ".") dot : pUStr (toUStr name) : loop ref
      AST_Subscript args     ref   -> pArgs "[]" args ++ loop ref
      AST_FuncCall  args     ref   -> pArgs "()" args ++ loop ref
      where
        pArgs str args = case str of
          (open:close:_) -> [pString [open], pPrint args, pString [close]]
          _              -> error "INTERNAL: bad instance definition of PPrintable AST_RefSuffix"

instance NFData o => NFData (AST_RefSuffix o) where
  rnf  AST_RefNull            = ()
  rnf (AST_DotRef    a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (AST_Subscript a b    ) = deepseq a $! deepseq b ()
  rnf (AST_FuncCall  a b    ) = deepseq a $! deepseq b ()

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RefSuffix o) where
  randO = recurse $ countNode $ runRandChoice
  randChoice = randChoiceList $
    [ return AST_RefNull
    , scramble $ return AST_DotRef    <*> randO <*> randO <*> randO <*> no
    , scramble $ return AST_Subscript <*> randO <*> randO
    , scramble $ return AST_FuncCall  <*> randO <*> randO
    ]
  defaultO = runDefaultChoice
  defaultChoice = randChoiceList $
    [ return AST_RefNull
    , return AST_DotRef <*> defaultO <*> randO <*> pure AST_RefNull <*> no
    , return AST_Subscript <*> pure nullValue <*> pure AST_RefNull
    , return AST_FuncCall  <*> pure nullValue <*> pure AST_RefNull
    ]

instance Intermediate (RefSuffixExpr o) (AST_RefSuffix o) where
  toInterm   ast = case ast of
    AST_RefNull                -> [NullRefExpr]
    AST_DotRef  _ name ref loc -> [DotRefExpr]    <*> [name]        <*> toInterm ref <*> [loc]
    AST_Subscript args ref     -> [SubscriptExpr] <*> toInterm args <*> toInterm ref
    AST_FuncCall  args ref     -> [FuncCallExpr]  <*> toInterm args <*> toInterm ref
  fromInterm obj = case obj of
    NullRefExpr                -> [AST_RefNull]
    DotRefExpr    name ref loc -> [AST_DotRef] <*> [Com ()] <*> [name] <*> fromInterm ref <*> [loc]
    SubscriptExpr args ref     -> [AST_Subscript] <*> fromInterm args <*> fromInterm ref
    FuncCallExpr  args ref     -> [AST_FuncCall]  <*> fromInterm args <*> fromInterm ref

----------------------------------------------------------------------------------------------------

data ReferenceExpr o
  = RefObjectExpr (ParenExpr o)     (RefSuffixExpr o) Location
  | ReferenceExpr RefQualifier Name (RefSuffixExpr o) Location
    -- ^ reference suffixed by square brackets or round brackets. If the 3rd parameter is False, it
    -- is suffixed by square brackets, and True means suffixed by round brackets. Square brackets
    -- indicates an indexing expression, round brackets indicates a function call.
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (ReferenceExpr o) where
  rnf (RefObjectExpr a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (ReferenceExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasNullValue (ReferenceExpr o) where
  nullValue = RefObjectExpr nullValue NullRefExpr LocationUnknown
  testNull (RefObjectExpr a NullRefExpr LocationUnknown) = testNull a
  testNull _                                             = False

instance HasLocation (ReferenceExpr o) where
  getLocation o     = case o of
    RefObjectExpr _ _   loc -> loc
    ReferenceExpr _ _ _ loc -> loc
  setLocation o loc = case o of
    RefObjectExpr a b _     -> RefObjectExpr a b   loc
    ReferenceExpr a b c loc -> ReferenceExpr a b c loc
  delLocation o    = case o of
    RefObjectExpr a b _     -> RefObjectExpr (delLocation a) b   LocationUnknown
    ReferenceExpr a b c _   -> ReferenceExpr              a  b c LocationUnknown

instance PPrintable o => PPrintable (ReferenceExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

data AST_Reference o
  = AST_RefObject (AST_Paren o)               (AST_RefSuffix o) Location
  | AST_Reference RefQualifier [Comment] Name (AST_RefSuffix o) Location
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (AST_Reference o) where
  rnf (AST_RefObject a b c    ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (AST_Reference a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e ()

instance HasLocation (AST_Reference o) where
  getLocation o     = case o of
    AST_RefObject _ _     loc -> loc
    AST_Reference _ _ _ _ loc -> loc
  setLocation o loc = case o of
    AST_RefObject a b     _   -> AST_RefObject a b     loc
    AST_Reference a b c d _   -> AST_Reference  a b c d loc
  delLocation o     = case o of
    AST_RefObject a b     _   -> AST_RefObject (delLocation a) (delLocation b) LocationUnknown
    AST_Reference a b c d _   -> AST_Reference a b c (delLocation d) LocationUnknown

instance PPrintable o => PPrintable (AST_Reference o) where
  pPrint o = pInline $ case o of
    AST_RefObject  o           ref _ -> [pPrint o, pPrint ref]
    AST_Reference  q coms name ref _ -> concat $
      [ if q==UNQUAL then [] else [pPrint q, pString " "]
      , [pPrint coms, pUStr (toUStr name), pPrint ref]
      ]

instance PrecedeWithSpace (AST_Reference o) where { precedeWithSpace _ = True }

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Reference o) where
  randO = countNode $ runRandChoice
  randChoice = randChoiceList $
    [ scramble $ return AST_Reference <*> randO <*> randO <*> randO <*> randO <*> no
    , scramble $ return AST_RefObject <*> randO <*> randO <*> no
    ]
  defaultO = runDefaultChoice
  defaultChoice = randChoiceList $
    [ return AST_Reference <*> defaultO <*> defaultO <*> defaultO <*> defaultO <*> no
    , return AST_RefObject <*> defaultO <*> defaultO <*> no
    ]

instance Intermediate (ReferenceExpr o) (AST_Reference o) where
  toInterm ast = case ast of
    AST_RefObject paren    ref loc -> [RefObjectExpr] <*> ti paren <*> ti ref            <*> [loc]
    AST_Reference q _ name ref loc -> [ReferenceExpr] <*> [q]      <*> [name] <*> ti ref <*> [loc]
  fromInterm o = case o of
    RefObjectExpr paren  ref loc -> [AST_RefObject] <*> fi paren <*> fi ref <*> [loc]
    ReferenceExpr q name ref loc ->
      [AST_Reference] <*> [q] <*> [[]] <*> [name]  <*> fi ref <*> [loc]

----------------------------------------------------------------------------------------------------

data RefPrefixExpr o
  = PlainRefExpr  (ReferenceExpr o)
  | RefPrefixExpr RefPfxOp (RefPrefixExpr o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

-- | Eliminate composed DEREF-REF operations
-- > @$a == a
cleanupRefPrefixExpr :: RefPrefixExpr o -> RefPrefixExpr o
cleanupRefPrefixExpr o =
  case o of { RefPrefixExpr DEREF (RefPrefixExpr REF o _) _ -> cleanupRefPrefixExpr o; _ -> o; }

instance NFData o => NFData (RefPrefixExpr o) where
  rnf (RefPrefixExpr a b c) = deepseq a $! deepseq b $! deepseq c ()
  rnf (PlainRefExpr  a    ) = deepseq a ()

instance HasNullValue (RefPrefixExpr o) where
  nullValue = PlainRefExpr nullValue
  testNull (PlainRefExpr a) = testNull a
  testNull _ = False

instance HasLocation (RefPrefixExpr o) where
  getLocation o     = case o of
    PlainRefExpr      o -> getLocation o
    RefPrefixExpr _ _ o -> o
  setLocation o loc = case o of
    PlainRefExpr  a     -> PlainRefExpr (setLocation a loc)
    RefPrefixExpr a b _ -> RefPrefixExpr a b loc
  delLocation o     = case o of
    PlainRefExpr  a     -> PlainRefExpr (delLocation a)
    RefPrefixExpr a b _ -> RefPrefixExpr a (delLocation b) LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_RefPrefix o
  = AST_PlainRef  (AST_Reference o)
  | AST_RefPrefix RefPfxOp [Comment] (AST_RefPrefix o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_RefPrefix o) where
  rnf (AST_PlainRef  a      ) = deepseq a ()
  rnf (AST_RefPrefix a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d  ()

instance HasLocation (AST_RefPrefix o) where
  getLocation o     = case o of
    AST_PlainRef  a         -> getLocation a
    AST_RefPrefix _ _ _ loc -> loc
  setLocation o loc = case o of
    AST_PlainRef  a         -> AST_PlainRef $ setLocation a loc
    AST_RefPrefix a b c _   -> AST_RefPrefix a b c loc
  delLocation o     = case o of
    AST_PlainRef  a         -> AST_PlainRef $ delLocation a
    AST_RefPrefix a b c _   -> AST_RefPrefix a b (delLocation c) LocationUnknown

instance PPrintable o => PPrintable (AST_RefPrefix o) where
  pPrint o = case o of
    AST_PlainRef o                   -> pPrint o
    AST_RefPrefix ariOp coms objXp _ -> pWrapIndent [pPrint ariOp, pPrint coms, pPrint objXp]

instance PrecedeWithSpace (AST_RefPrefix o) where
  precedeWithSpace o = case o of
    AST_PlainRef _ -> True
    _              -> False

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RefPrefix o) where
  randO      = recurse $ countNode $ runRandChoice
  randChoice = randChoiceList $
    [ return AST_PlainRef  <*> randO
    , return AST_RefPrefix <*> randO <*> randO <*> randO <*> no
    ]
  defaultO      = runDefaultChoice
  defaultChoice = randChoiceList $
    [ AST_PlainRef <$> defaultO
    , return AST_RefPrefix <*> defaultO <*> defaultO <*> (AST_PlainRef <$> defaultO) <*> no
    ]

instance Intermediate (RefPrefixExpr o) (AST_RefPrefix o) where
  toInterm ast = case ast of
    AST_PlainRef  a         -> PlainRefExpr <$> toInterm a
    AST_RefPrefix a _ c loc -> [RefPrefixExpr] <*> [a] <*> toInterm c <*> [loc]
  fromInterm o = case o of
    PlainRefExpr  a       -> AST_PlainRef <$> fromInterm a
    RefPrefixExpr a c loc -> [AST_RefPrefix] <*> [a] <*> [[]] <*> fromInterm c <*> [loc]

----------------------------------------------------------------------------------------------------

-- | Contains a list of 'ObjectExpr's, which are used to encode parameters to function calls, and
-- intialization lists.
data ObjListExpr o = ObjListExpr [AssignExpr o] Location deriving (Eq, Ord, Typeable, Show, Functor)

instance Monoid (ObjListExpr o) where
  mempty = ObjListExpr [] LocationUnknown
  mappend (ObjListExpr a locA) (ObjListExpr b locB) = ObjListExpr (a++b) (locA<>locB)

instance NFData o => NFData (ObjListExpr o) where { rnf (ObjListExpr a b) = deepseq a $! deepseq b () }

instance HasNullValue (ObjListExpr o) where
  nullValue = mempty
  testNull (ObjListExpr a _) = null a

instance HasLocation (ObjListExpr o) where
  getLocation (ObjListExpr _ loc)     = loc
  setLocation (ObjListExpr a _  ) loc = ObjListExpr (fmap delLocation a) loc
  delLocation (ObjListExpr a _  )     = ObjListExpr (fmap delLocation a) LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_ObjList o = AST_ObjList [Comment] [Com (AST_Assign o)] Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance Monoid (AST_ObjList o) where
  mempty = AST_ObjList [] [] LocationUnknown
  mappend (AST_ObjList a1 a2 aloc) (AST_ObjList b1 b2 bloc) = AST_ObjList (a1++b1) (a2++b2) (aloc<>bloc)

instance HasNullValue (AST_ObjList o) where
  nullValue = mempty
  testNull (AST_ObjList [] [] _) = True
  testNull _ = False

instance HasLocation (AST_ObjList o) where
  getLocation (AST_ObjList _ _ loc)     = loc
  setLocation (AST_ObjList a b _  ) loc = AST_ObjList a      b  loc
  delLocation (AST_ObjList a b _  )     = AST_ObjList a (fmap delLocation b) LocationUnknown

instance PPrintable o => PPrintable (AST_ObjList o) where
  pPrint (AST_ObjList coms lst _) = pPrint coms >>
    pInline (intersperse (pString ", ") (map pPrint lst))

instance NFData o => NFData (AST_ObjList o) where { rnf (AST_ObjList a b c) = deepseq a $! deepseq b $! deepseq c () }

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ObjList o) where
  randO = recurse $ depthLimitedInt 8 >>= \x -> AST_ObjList <$> randO <*> randList 0 x <*> no
  defaultO = return AST_ObjList <*> defaultO <*> pure [] <*> no

instance Intermediate (ObjListExpr o) (AST_ObjList o) where
  toInterm   (AST_ObjList _ lst loc) = [ObjListExpr]          <*> [lst>>=uc0] <*> [loc]
  fromInterm (ObjListExpr   lst loc) = [AST_ObjList] <*> [[]] <*> [lst>>=nc0] <*> [loc]

----------------------------------------------------------------------------------------------------

newtype OptObjListExpr o = OptObjListExpr (Maybe (ObjListExpr o))
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (OptObjListExpr o) where { rnf (OptObjListExpr a) = deepseq a () }

instance HasLocation (OptObjListExpr o) where
  getLocation (OptObjListExpr o)     = maybe LocationUnknown getLocation o
  setLocation (OptObjListExpr o) loc = OptObjListExpr (setLocation o loc)
  delLocation (OptObjListExpr o)     = OptObjListExpr (delLocation o    )

instance HasNullValue (OptObjListExpr o) where
  nullValue = OptObjListExpr Nothing
  testNull (OptObjListExpr Nothing) = True
  testNull _ = False

----------------------------------------------------------------------------------------------------

data AST_OptObjList o = AST_OptObjList [Comment] (Maybe (AST_ObjList o))
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_OptObjList o) where
  rnf (AST_OptObjList a b) = deepseq a $! deepseq b ()

instance HasNullValue (AST_OptObjList o) where
  nullValue = AST_OptObjList [] Nothing
  testNull (AST_OptObjList _ a) = maybe True testNull a

pPrintObjList :: PPrintable o => String -> String -> String -> AST_ObjList o -> PPrint
pPrintObjList open comma close (AST_ObjList coms lst _) = pList (pPrint coms) open comma close (map pPrint lst)

pPrintOptObjList :: PPrintable o => String -> String -> String -> AST_OptObjList o -> PPrint
pPrintOptObjList open comma close (AST_OptObjList coms o) =
  maybe (return ()) (\o -> pPrint coms >> pPrintObjList open comma close o) o

instance HasLocation (AST_OptObjList o) where
  getLocation (AST_OptObjList _ o)     = maybe LocationUnknown getLocation o
  setLocation (AST_OptObjList c o) loc = AST_OptObjList c (fmap (flip setLocation loc) o)
  delLocation (AST_OptObjList c o)     = AST_OptObjList c (fmap delLocation o)

instance PPrintable o => PPrintable (AST_OptObjList o) where { pPrint o = pPrintOptObjList "{" ", " "}" o }

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_OptObjList o) where
  randO = countNode $ return AST_OptObjList <*> randO <*> randO
  defaultO = return AST_OptObjList <*> defaultO <*> defaultO

instance Intermediate (OptObjListExpr o) (AST_OptObjList o) where
  toInterm   (AST_OptObjList _ o) = OptObjListExpr    <$> um1 o
  fromInterm (OptObjListExpr   o) = AST_OptObjList [] <$> nm1 o

----------------------------------------------------------------------------------------------------

data LiteralExpr o = LiteralExpr o Location deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (LiteralExpr o) where
  rnf (LiteralExpr a b) = deepseq a $! deepseq b ()

instance {- KEEP -} HasNullValue o => HasNullValue (LiteralExpr o) where
  nullValue = LiteralExpr nullValue LocationUnknown
  testNull (LiteralExpr o _) = testNull o

instance HasLocation (LiteralExpr o) where
  getLocation (LiteralExpr _ loc)     = loc
  setLocation (LiteralExpr o _  ) loc = LiteralExpr o loc
  delLocation (LiteralExpr o _  )     = LiteralExpr o LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_Literal o = AST_Literal o Location deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_Literal o) where
  rnf (AST_Literal a b) = deepseq a $! deepseq b ()

instance {- KEEP -} HasNullValue o => HasNullValue (AST_Literal o) where
  nullValue = AST_Literal nullValue LocationUnknown
  testNull (AST_Literal o _) = testNull o

instance HasLocation (AST_Literal o) where
  getLocation (AST_Literal _ loc)     = loc
  setLocation (AST_Literal a _  ) loc = AST_Literal a loc
  delLocation (AST_Literal a _  )     = AST_Literal a LocationUnknown

instance PPrintable o => PPrintable (AST_Literal o) where
  pPrint (AST_Literal o _  ) = pPrint o

instance PrecedeWithSpace (AST_Literal o) where
  precedeWithSpace (AST_Literal _ _) = True

instance HasRandGen o => HasRandGen (AST_Literal o) where
  randO    = scramble $ return AST_Literal <*> defaultO <*> no
  defaultO = randO

instance Intermediate (LiteralExpr o) (AST_Literal o) where
  toInterm   (AST_Literal a loc) = [LiteralExpr] <*> [a] <*> [loc]
  fromInterm (LiteralExpr a loc) = [AST_Literal] <*> [a] <*> [loc]

----------------------------------------------------------------------------------------------------

-- | Required parenthesese.
data ParenExpr o = ParenExpr (AssignExpr o) Location deriving (Eq, Ord, Typeable, Show, Functor)

instance HasLocation (ParenExpr o) where
  getLocation (ParenExpr _ loc)     = loc
  setLocation (ParenExpr o _  ) loc = ParenExpr o loc
  delLocation (ParenExpr o _  )     = ParenExpr (delLocation o) LocationUnknown

instance HasNullValue (ParenExpr o) where
  nullValue = ParenExpr nullValue LocationUnknown
  testNull (ParenExpr a _) = testNull a

instance NFData o => NFData (ParenExpr o) where { rnf (ParenExpr a b) = deepseq a $! deepseq b () }

instance PPrintable o => PPrintable (ParenExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

data AST_Paren o = AST_Paren (Com (AST_Assign o)) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance HasLocation (AST_Paren o) where
  getLocation (AST_Paren _ loc)     = loc
  setLocation (AST_Paren o _  ) loc = AST_Paren o loc
  delLocation (AST_Paren o _  )     = AST_Paren (delLocation o) LocationUnknown

instance HasNullValue (AST_Paren o) where
  nullValue = AST_Paren nullValue LocationUnknown
  testNull (AST_Paren a _) = testNull a

instance NFData o => NFData (AST_Paren o) where { rnf (AST_Paren a b) = deepseq a $! deepseq b () }

instance PPrintable o => PPrintable (AST_Paren o) where
  pPrint (AST_Paren o _) = pInline [pString "(", pPrint o, pString ")"]

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Paren o) where
  randO    = recurse $ return AST_Paren <*> randO <*> no
  defaultO = return AST_Paren <*> defaultO <*> no

instance Intermediate (ParenExpr o) (AST_Paren o) where
  toInterm   (AST_Paren o loc) = [ParenExpr] <*> uc0 o <*> [loc]
  fromInterm (ParenExpr o loc) = [AST_Paren] <*> nc0 o <*> [loc]

----------------------------------------------------------------------------------------------------

data AssignExpr o
  = EvalExpr   (ObjTestExpr o)
  | AssignExpr (ObjTestExpr o) UpdateOp (AssignExpr o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AssignExpr o) where
  rnf (EvalExpr   a      ) = deepseq a ()
  rnf (AssignExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasNullValue (AssignExpr o) where
  nullValue = EvalExpr nullValue
  testNull (EvalExpr a) = testNull a
  testNull _ = False

instance HasLocation (AssignExpr o) where
  getLocation o     = case o of
    EvalExpr         o -> getLocation o
    AssignExpr _ _ _ o -> o
  setLocation o loc = case o of
    EvalExpr   a       -> EvalExpr  (setLocation a loc)
    AssignExpr a b c _ -> AssignExpr a b c loc
  delLocation o     = case o of
    EvalExpr   a       -> EvalExpr   (delLocation a)
    AssignExpr a b c _ -> AssignExpr (delLocation a) b (delLocation c) LocationUnknown

instance PPrintable o => PPrintable (AssignExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

data AST_Assign o
  = AST_Eval   (AST_ObjTest o)
  | AST_Assign (AST_ObjTest o) (Com UpdateOp) (AST_Assign o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_Assign o) where
  rnf (AST_Eval   a      ) = deepseq a ()
  rnf (AST_Assign a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasNullValue (AST_Assign o) where
  nullValue = AST_Eval  nullValue
  testNull (AST_Eval  a) = testNull a
  testNull _ = False

instance HasLocation (AST_Assign o) where
  getLocation o = case o of
    AST_Eval         o -> getLocation o
    AST_Assign _ _ _ o -> o
  setLocation o loc = case o of
    AST_Eval         o -> AST_Eval  (setLocation o loc)
    AST_Assign a b c _ -> AST_Assign a b c loc
  delLocation o = case o of                            
    AST_Eval         o -> AST_Eval  (delLocation o)
    AST_Assign a b c _ -> AST_Assign (delLocation a) b (delLocation c) LocationUnknown

instance PPrintable o => PPrintable (AST_Assign o) where
  pPrint expr = case expr of
    AST_Eval  eq -> pPrint eq
    AST_Assign objXp1 comUpdOp objXp2 _ -> pWrapIndent $
      [pPrint objXp1, pPrint comUpdOp, pPrint objXp2]

instance PrecedeWithSpace (AST_Assign o) where
  precedeWithSpace o = case o of
    AST_Eval   o       -> precedeWithSpace o
    AST_Assign o _ _ _ -> precedeWithSpace o

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Assign o) where
  randO = countNode $ recurse $ runRandChoice
  randChoice = randChoiceList $
    [ AST_Eval <$> randO
    , do ox <- randListOf 0 3 (pure (,) <*> randO <*> randO)
         o  <- randO
         return (foldr (\ (left, op) right -> AST_Assign left op right LocationUnknown) o ox)
    ]
  defaultO      = runDefaultChoice
  defaultChoice = randChoiceList $
    [ AST_Eval <$> defaultO
    , return AST_Assign <*> defaultO <*> defaultO <*> (AST_Eval <$> defaultO) <*> no
    ]

instance Intermediate (AssignExpr o) (AST_Assign o) where
  toInterm ast = case ast of
    AST_Eval   a         -> EvalExpr <$> ti a
    AST_Assign a b c loc -> [AssignExpr] <*> ti a <*> uc b <*> ti c <*> [loc]
  fromInterm o = case o of
    EvalExpr   a         -> AST_Eval <$> fi a
    AssignExpr a b c loc -> [AST_Assign] <*> fi a <*> nc b <*> fi c <*> [loc]

----------------------------------------------------------------------------------------------------

-- | A conditional expression of the form @a==b ? "yes" : "no"@
data ObjTestExpr o
  = ObjArithExpr    (ArithExpr    o)
  | ObjTestExpr     (ArithExpr    o) (ArithExpr o) (ArithExpr o) Location
  | ObjRuleFuncExpr (RuleFuncExpr o)
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (ObjTestExpr o) where
  rnf (ObjArithExpr  a    ) = deepseq a ()
  rnf (ObjTestExpr a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (ObjRuleFuncExpr a      ) = deepseq a $! ()

instance HasNullValue (ObjTestExpr o) where
  nullValue = ObjArithExpr nullValue
  testNull (ObjArithExpr a) = testNull a
  testNull _ = False

instance HasLocation (ObjTestExpr o) where
  getLocation o = case o of
    ObjArithExpr      a   -> getLocation a
    ObjTestExpr _ _ _ loc -> loc
    ObjRuleFuncExpr       o -> getLocation o
  setLocation o loc = case o of
    ObjArithExpr      a   -> ObjArithExpr (setLocation a loc)
    ObjTestExpr a b c _   -> ObjTestExpr a b c loc
    ObjRuleFuncExpr a       -> ObjRuleFuncExpr (setLocation a loc)
  delLocation o     = case o of
    ObjArithExpr      a   -> ObjArithExpr (delLocation a)
    ObjTestExpr a b c _   ->
      ObjTestExpr (delLocation a) (delLocation b) (delLocation c) LocationUnknown
    ObjRuleFuncExpr a       -> ObjRuleFuncExpr (delLocation a)

instance PPrintable o => PPrintable (ObjTestExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

-- | A conditional expression of the form @a==b ? "yes" : "no"@
data AST_ObjTest o
  = AST_ObjArith    (AST_Arith    o)
  | AST_ObjTest     (AST_Arith    o) (Com ()) (AST_Arith o) (Com ()) (AST_Arith o) Location
  | AST_ObjRuleFunc (AST_RuleFunc o)
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (AST_ObjTest o) where
  rnf (AST_ObjArith  a        ) = deepseq a ()
  rnf (AST_ObjTest a b c d e f) =
    deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e $! deepseq f ()
  rnf (AST_ObjRuleFunc a      ) = deepseq a ()

instance HasNullValue (AST_ObjTest o) where
  nullValue = AST_ObjArith nullValue
  testNull (AST_ObjArith a) = testNull a
  testNull _ = False

instance HasLocation (AST_ObjTest o) where
  getLocation o     = case o of
    AST_ObjArith          a   -> getLocation a
    AST_ObjTest _ _ _ _ _ loc -> loc
    AST_ObjRuleFunc      o -> getLocation o
  setLocation o loc = case o of
    AST_ObjArith          a   -> AST_ObjArith (setLocation a loc)
    AST_ObjTest a b c d e _   -> AST_ObjTest a b c d e loc
    AST_ObjRuleFunc a         -> AST_ObjRuleFunc (setLocation a loc)
  delLocation o     = case o of
    AST_ObjArith          a   -> AST_ObjArith (delLocation a)
    AST_ObjTest a b c d e _   -> 
      AST_ObjTest (delLocation a) b (delLocation c) d (delLocation e) LocationUnknown
    AST_ObjRuleFunc a         -> AST_ObjRuleFunc (delLocation  a)

instance PPrintable o => PPrintable (AST_ObjTest o) where
  pPrint o = case o of
    AST_ObjArith  a         -> pPrint a
    AST_ObjTest a b c d e _ -> pWrapIndent $
      [ pPrint a
      , pPrintComWith (\ () -> pString " ? ") b, pPrint c
      , pPrintComWith (\ () -> pString " : ") d, pPrint e
      ]
    AST_ObjRuleFunc o                -> pPrint o

instance PrecedeWithSpace (AST_ObjTest o) where
  precedeWithSpace o = case o of
    AST_ObjArith          o -> precedeWithSpace o
    AST_ObjTest o _ _ _ _ _ -> precedeWithSpace o
    AST_ObjRuleFunc{}       -> True

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ObjTest o) where
  randO      = countNode $ runRandChoice
  randChoice = randChoiceList $
    [ AST_ObjArith <$> randO
    , let p = pure (Com ()) in
        recurse $ scramble $ return AST_ObjTest <*> randO <*> p <*> randO <*> p <*> randO <*> no
    , AST_ObjRuleFunc <$> randO
    ]
  defaultO      = AST_ObjArith <$> defaultO
  defaultChoice = randChoiceList [defaultO]

instance Intermediate (ObjTestExpr o) (AST_ObjTest o) where
  toInterm   o = case o of
    AST_ObjArith    o         ->  ObjArithExpr <$> ti o
    AST_ObjTest a _ b _ c loc -> [ObjTestExpr] <*> ti a <*> ti b <*> ti c <*> [loc]
    AST_ObjRuleFunc a         -> [ObjRuleFuncExpr] <*> ti a
  fromInterm o = case o of
    ObjArithExpr  o       -> AST_ObjArith <$> fi o
    ObjTestExpr a b c loc ->
      [AST_ObjTest] <*> fi a <*> [Com ()] <*> fi b <*> [Com ()] <*> fi c <*> [loc]
    ObjRuleFuncExpr a         ->  AST_ObjRuleFunc  <$> fi a

----------------------------------------------------------------------------------------------------

data RefPfxOp = REF | DEREF deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)

instance NFData RefPfxOp where { rnf a = seq a () }

instance UStrType RefPfxOp where
  toUStr op = ustr $ case op of
    REF         -> "$"
    DEREF       -> "@"
  maybeFromUStr str = case uchars str of
    "$" -> Just REF
    "@" -> Just DEREF
    _   -> Nothing
  fromUStr str = maybe (error (show str++" is not a prefix opretor")) id (maybeFromUStr str)

instance PPrintable RefPfxOp where { pPrint = pUStr . toUStr }

instance HasRandGen RefPfxOp where
  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::RefPfxOp)))
  defaultO = randO

----------------------------------------------------------------------------------------------------

data UpdateOp
  = UCONST | UADD | USUB | UMULT | UDIV | UMOD | UPOW | UORB | UANDB | UXORB | USHL | USHR
  deriving (Eq, Ord, Typeable, Enum, Ix, Bounded, Show, Read)
instance NFData UpdateOp where { rnf a = seq a () }

allUpdateOpStrs :: String
allUpdateOpStrs = " = += -= *= /= %= **= |= &= ^= <<= >>= "

instance UStrType UpdateOp where
  toUStr a = ustr $ case a of
    UCONST -> "="
    UADD   -> "+="
    USUB   -> "-="
    UMULT  -> "*="
    UDIV   -> "/="
    UMOD   -> "%="
    UPOW   -> "**="
    UORB   -> "|="
    UANDB  -> "&="
    UXORB  -> "^="
    USHL   -> "<<="
    USHR   -> ">>="
  maybeFromUStr str = case uchars str of
    "="   -> Just UCONST
    "+="  -> Just UADD  
    "-="  -> Just USUB  
    "*="  -> Just UMULT 
    "/="  -> Just UDIV  
    "%="  -> Just UMOD  
    "**=" -> Just UPOW
    "|="  -> Just UORB  
    "&="  -> Just UANDB 
    "^="  -> Just UXORB 
    "<<=" -> Just USHL  
    ">>=" -> Just USHR  
    _     -> Nothing
  fromUStr str =
    maybe (error (show str++" is not an assignment/update operator")) id (maybeFromUStr str)

instance PPrintable UpdateOp where { pPrint op = pString (' ':uchars op++" ") }

-- binary 0x8D 0x9D UpdateOp-->InfixOp
instance B.Binary UpdateOp mtab where
  put o = B.putWord8 $ case o of
    UCONST -> 0x8D
    UADD   -> 0x93
    USUB   -> 0x94
    UMULT  -> 0x95
    UDIV   -> 0x96
    UMOD   -> 0x97
    UPOW   -> 0x98
    UORB   -> 0x99
    UANDB  -> 0x9A
    UXORB  -> 0x9B
    USHL   -> 0x9C
    USHR   -> 0x9D
  get = B.word8PrefixTable <|> fail "expecting UpdateOp"

instance B.HasPrefixTable UpdateOp B.Byte mtab where
  prefixTable = B.mkPrefixTableWord8 "UpdateOp" 0x8D 0x9D $ let {r=return;z=mzero} in
    [ r UCONST -- 0x8D
    , z, z, z, z, z -- 0x8E,0x8F,0x90,0x91,0x92
    , r UADD, r USUB, r UMULT, r UDIV, r UMOD, r UPOW, r UORB -- 0x93,0x94,0x95,0x96,0x97,0x98,0x99
    , r UANDB, r UXORB, r USHL, r USHR -- 0x9A,0x9B,0x9C,0x9D
    ]

instance HasRandGen UpdateOp where
  randO = fmap toEnum (nextInt (1+fromEnum (maxBound::UpdateOp)))
  defaultO = randO

----------------------------------------------------------------------------------------------------

data ArithExpr o
  = ObjectExpr (ObjectExpr o)
  | ArithExpr  (ArithExpr  o) InfixOp (ArithExpr o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (ArithExpr o) where
  rnf (ObjectExpr a      ) = deepseq a ()
  rnf (ArithExpr  a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasNullValue (ArithExpr o) where
  nullValue = ObjectExpr nullValue
  testNull (ObjectExpr a) = testNull a
  testNull _ = False

instance HasLocation (ArithExpr o) where
  getLocation o     = case o of
    ObjectExpr      o -> getLocation o
    ArithExpr _ _ _ o -> o
  setLocation o loc = case o of
    ObjectExpr  a     -> ObjectExpr (setLocation a loc)
    ArithExpr a b c _ -> ArithExpr a b c loc
  delLocation o     = case o of
    ObjectExpr  a     -> ObjectExpr (delLocation a)
    ArithExpr a b c _ -> ArithExpr (delLocation a) b (delLocation c) LocationUnknown

instance PPrintable o => PPrintable (ArithExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

data AST_Arith o
  = AST_Object (AST_Object o)
  | AST_Arith  (AST_Arith  o) (Com InfixOp) (AST_Arith o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_Arith o) where
  rnf (AST_Object   a        ) = deepseq a ()
  rnf (AST_Arith a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasNullValue (AST_Arith o) where
  nullValue = AST_Object nullValue
  testNull (AST_Object a) = testNull a
  testNull _ = False

instance HasLocation (AST_Arith o) where
  getLocation o     = case o of
    AST_Object      o -> getLocation o
    AST_Arith _ _ _ o -> o
  setLocation o loc = case o of
    AST_Object   a    -> AST_Object (setLocation a loc)
    AST_Arith a b c _ -> AST_Arith a b c loc
  delLocation o     = case o of
    AST_Object   a    -> AST_Object (delLocation a)
    AST_Arith a b c _ -> AST_Arith (delLocation a) b (delLocation c) LocationUnknown

instance PPrintable o => PPrintable (AST_Arith o) where
  pPrint o = case o of
    AST_Object o -> pPrint o
    AST_Arith objXp1 comAriOp objXp2 _ -> pWrapIndent [pPrint objXp1, pPrint comAriOp, pPrint objXp2]

instance PrecedeWithSpace (AST_Arith o) where
  precedeWithSpace o = case o of
    AST_Object o       -> precedeWithSpace o
    AST_Arith  o _ _ _ -> precedeWithSpace o

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Arith o) where
  randO = countNode $ runRandChoice
  defaultChoice = randChoiceList $
    [ AST_Object <$> defaultO
    , return AST_Arith <*> (AST_Object <$> defaultO) <*> defaultO <*> (AST_Object <$> defaultO) <*> no
    ]
  defaultO   = runDefaultChoice
  randChoice = randChoiceList $
    [ AST_Object <$> randO
    , do  left <- AST_Object <$> randO
          x    <- getCurrentDepth
          ops  <- randListOf 0 (max 1 (4-x)) $
            pure (,) <*> randInfixOp <*> (AST_Object <$> randO)
          return $ foldPrec left ops
    ] where
      randInfixOp :: RandO (Com InfixOp, Int, Bool)
      randInfixOp = do
        (op, prec, assoc) <- runRandChoiceOf opGroups
        op <- randComWith (return op)
        return (op, prec, assoc)
      left  op = (True , op)
      right op = (False, op)
      opGroups :: RandChoice (InfixOp, Int, Bool)
      opGroups = randChoiceList $ map return $ do
        (precedence, (associativity, operators)) <- zip [1..] $ concat $
          [ map right [[OR], [AND], [EQUL, NEQUL]]
          , map left $
              [ [GTN, LTN, GTEQ, LTEQ], [SHL, SHR]
              , [ORB], [XORB], [ANDB]
              , [ADD, SUB], [MULT, DIV, MOD]
              ]
          , map right [[POW], [ARROW]]
          ]
        operator <- operators
        return (operator, precedence, associativity)
      bind left op right = AST_Arith left op right LocationUnknown
      foldPrec left ops = case ops of
        [] -> left
        ((op, prec, _), right):ops -> case scanRight prec right ops of
          (right, ops) -> foldPrec (bind left op right) ops
      scanRight prevPrec left ops = case ops of
        [] -> (left, [])
        ((op, prec, assoc), right):next -> 
          if prevPrec<prec || (prevPrec==prec && not assoc)
          then  case scanRight prec right next of
                  (right, next) -> scanRight prevPrec (bind left op right) next
          else  (left, ops)

instance Intermediate (ArithExpr o) (AST_Arith o) where
  toInterm o = case o of
    AST_Object  a       -> ObjectExpr <$> ti a
    AST_Arith a b c loc -> [ArithExpr ] <*> ti a <*> uc b <*> ti c <*> [loc]
  fromInterm o = case o of
    ObjectExpr  a       -> AST_Object <$> fi a
    ArithExpr a b c loc -> [AST_Arith ] <*> fi a <*> nc b <*> fi c <*> [loc]

----------------------------------------------------------------------------------------------------

data ObjectExpr o
  = VoidExpr
  | ObjLiteralExpr  (LiteralExpr   o)
  | ObjSingleExpr   (RefPrefixExpr o)
  | ArithPfxExpr     ArithPfxOp       (ObjectExpr     o)                  Location
  | InitExpr         DotLabelExpr     (OptObjListExpr o)  (ObjListExpr o) Location
  | StructExpr       Name             (OptObjListExpr o)                  Location
  | MetaEvalExpr    (CodeBlock     o)                                     Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (ObjectExpr o) where
  rnf  VoidExpr                 = ()
  rnf (ObjLiteralExpr  a      ) = deepseq a ()
  rnf (ObjSingleExpr   a      ) = deepseq a $! ()
  rnf (ArithPfxExpr    a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (InitExpr        a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (StructExpr      a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (MetaEvalExpr    a b    ) = deepseq a $! deepseq b ()

instance HasNullValue (ObjectExpr o) where
  nullValue = VoidExpr
  testNull VoidExpr = True
  testNull _        = False

instance HasLocation (ObjectExpr o) where
  getLocation o = case o of
    VoidExpr                -> LocationUnknown
    ObjLiteralExpr        o -> getLocation o
    ObjSingleExpr         o -> getLocation o
    ArithPfxExpr    _ _   o -> o
    InitExpr        _ _ _ o -> o
    StructExpr      _ _   o -> o
    MetaEvalExpr    _     o -> o
  setLocation o loc = case o of
    VoidExpr                -> VoidExpr
    ObjLiteralExpr  a       -> ObjLiteralExpr  (setLocation a loc)
    ObjSingleExpr   a       -> ObjSingleExpr   (setLocation a loc)
    ArithPfxExpr    a b   _ -> ArithPfxExpr    a b   loc
    InitExpr        a b c _ -> InitExpr        a b c loc
    StructExpr      a b   _ -> StructExpr      a b   loc
    MetaEvalExpr    a     _ -> MetaEvalExpr    a     loc
  delLocation o = case o of
    VoidExpr                -> VoidExpr
    ObjLiteralExpr  a       -> ObjLiteralExpr  (fd a)
    ObjSingleExpr   a       -> ObjSingleExpr   (fd a)
    ArithPfxExpr    a b   _ -> ArithPfxExpr        a  (fd b)        lu
    InitExpr        a b c _ -> InitExpr        (fd a) (fd b) (fd c) lu
    StructExpr      a b   _ -> StructExpr      (fd a) (fd b)        lu
    MetaEvalExpr    a     _ -> MetaEvalExpr    (fd a)               lu
    where
      lu = LocationUnknown
      fd :: HasLocation a => a -> a
      fd = delLocation

instance PPrintable o => PPrintable (ObjectExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

-- | Part of the Dao language abstract syntax tree: any expression that evaluates to an Object.
data AST_Object o
  = AST_Void -- ^ Not a language construct, but used where an object expression is optional.
  | AST_ObjLiteral  (AST_Literal o)
  | AST_ObjSingle   (AST_RefPrefix o)
  | AST_ArithPfx     ArithPfxOp      [Comment]          (AST_Object  o)   Location
  | AST_Init         AST_DotLabel    (AST_OptObjList o) (AST_ObjList o)   Location
  | AST_Struct       Name            (AST_OptObjList o)                   Location
  | AST_MetaEval                     (AST_CodeBlock  o)                   Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_Object o) where
  rnf AST_Void = ()
  rnf (AST_ObjLiteral  a      ) = deepseq a ()
  rnf (AST_ObjSingle   a      ) = deepseq a ()
  rnf (AST_ArithPfx    a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (AST_Init        a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (AST_Struct      a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (AST_MetaEval    a b    ) = deepseq a $! deepseq b ()

instance HasNullValue (AST_Object o) where
  nullValue = AST_Void
  testNull AST_Void = True
  testNull _        = False

instance HasLocation (AST_Object o) where
  getLocation o = case o of
    AST_Void               -> LocationUnknown
    AST_ObjLiteral       o -> getLocation o
    AST_ObjSingle        o -> getLocation o
    AST_ArithPfx _ _ _   o -> o
    AST_Init     _ _ _   o -> o
    AST_Struct   _ _     o -> o
    AST_MetaEval _       o -> o
  setLocation o loc = case o of
    AST_Void                  -> AST_Void
    AST_ObjLiteral  a         -> AST_ObjLiteral  (setLocation a loc)
    AST_ObjSingle   a         -> AST_ObjSingle   (setLocation a loc)
    AST_ArithPfx    a b c   _ -> AST_ArithPfx    a b c   loc
    AST_Init        a b c   _ -> AST_Init        a b c   loc
    AST_Struct      a b     _ -> AST_Struct      a b     loc
    AST_MetaEval    a       _ -> AST_MetaEval    a       loc
  delLocation o = case o of                            
    AST_Void                  -> AST_Void
    AST_ObjLiteral  a         -> AST_ObjLiteral   (delLocation  a)
    AST_ObjSingle   a         -> AST_ObjSingle    (delLocation  a)
    AST_ArithPfx    a b c   _ -> AST_ArithPfx a b (delLocation  c) LocationUnknown
    AST_Init        a b c   _ -> AST_Init         (delLocation  a) (delLocation  b) (delLocation  c) LocationUnknown
    AST_Struct      a b     _ -> AST_Struct   a   (delLocation  b) LocationUnknown
    AST_MetaEval    a       _ -> AST_MetaEval     (delLocation  a) LocationUnknown

instance PPrintable o => PPrintable (AST_Object o) where
  pPrint expr = case expr of
    AST_Void                         -> return ()
    AST_ObjLiteral  o                -> pPrint o
    AST_ObjSingle   o                -> pPrint o
    AST_ArithPfx    op coms objXp  _ -> pWrapIndent $
      [pPrint op, pPrint coms, pPrint objXp]
    AST_Init          ref objs     elems   _ ->
      pInline [pPrint ref, pPrintOptObjList "(" ", " ")" objs, pPrintObjList "{" ", " "}" elems]
    AST_Struct      nm itms        _ -> case itms of
      AST_OptObjList coms items -> do
        let name = pString $ '#' : uchars (toUStr nm)
        pPrint coms
        case items of
          Nothing -> name
          Just (AST_ObjList coms items _) -> do
            pPrint coms
            pList name "{" ", " "}" $ map pPrint items
    AST_MetaEval cObjXp                    _ -> pInline [pString "${", pPrint cObjXp, pString "}"]

instance PrecedeWithSpace (AST_Object o) where
  precedeWithSpace o = case o of
    AST_Void         -> False
    AST_MetaEval{}   -> False
    AST_ObjSingle  o -> precedeWithSpace o
    _                -> True

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Object o) where
  randO      = countNode $ runRandChoice
  randChoice = randChoiceList $
    [ AST_ObjLiteral  <$> randO
    , AST_ObjSingle   <$> randO
    , pure AST_ArithPfx <*> randO <*> randO <*> randO <*> no
    , pure AST_Init     <*> randO <*> randO <*> randO <*> no
    , pure AST_MetaEval <*> randO <*> no
    ]
  defaultO      = runDefaultChoice
  defaultChoice = randChoiceList $
    [ AST_ObjLiteral  <$> defaultO
    , AST_ObjSingle   <$> defaultO
    , return AST_ArithPfx <*> defaultO <*> defaultO <*> (AST_ObjLiteral <$> defaultO) <*> no
    , return AST_Init     <*> defaultO <*> defaultO <*> defaultO <*> no
    , return AST_Struct   <*> defaultO <*> defaultO <*> no
    ]

instance (HasNullValue o, HasRandGen o) => HasRandGen [Com (AST_Object o)] where
  randO = depthLimitedInt 24 >>= \x -> countNode $ randList 1 x

instance Intermediate (ObjectExpr o) (AST_Object o) where
  toInterm ast = case ast of
    AST_Void                  -> [VoidExpr       ]
    AST_ObjLiteral  a         ->  ObjLiteralExpr   <$> ti a
    AST_ObjSingle   a         -> [ObjSingleExpr  ] <*> ti a
    AST_ArithPfx    a _ c loc -> [ArithPfxExpr   ] <*>   [a]          <*> ti c <*> [loc]
    AST_Init        a b c loc -> [InitExpr       ] <*> ti a  <*> ti b <*> ti c <*> [loc]
    AST_Struct      a b   loc -> [StructExpr     ] <*>   [a] <*> ti b          <*> [loc]
    AST_MetaEval    a     loc -> [MetaEvalExpr   ] <*> ti a                    <*> [loc]
  fromInterm o = case o of
    VoidExpr                  -> [AST_Void       ]
    ObjLiteralExpr  a         ->  AST_ObjLiteral   <$> fi a
    ObjSingleExpr   a         ->  AST_ObjSingle    <$> fi a
    ArithPfxExpr    a b   loc -> [AST_ArithPfx   ] <*>   [a] <*> [[]] <*> fi b <*> [loc]
    InitExpr        a b c loc -> [AST_Init       ] <*> fi a  <*> fi b <*> fi c <*> [loc]
    StructExpr      a b   loc -> [AST_Struct     ] <*>   [a] <*> fi b          <*> [loc]
    MetaEvalExpr    a     loc -> [AST_MetaEval   ] <*> fi a                    <*> [loc]

----------------------------------------------------------------------------------------------------

-- | Functions and function parameters can specify optional type-checking expressions. This is a
-- data type that wraps a dao-typeable expression with type information.
data TyChkExpr a o
  = NotTypeChecked{tyChkItem::a}
    -- ^ no type information was specified for this item
  | TypeChecked   {tyChkItem::a, tyChkExpr::ArithExpr o, tyChkLoc::Location}
    -- ^ type check information was specified and should be checked every time it is evaluated.
  | DisableCheck  {tyChkItem::a, tyChkExpr::ArithExpr o, typChkResult::o, tyChkLoc::Location}
    -- ^ type check information was specified but has been disabled for efficiency reasons because
    -- we have verified that the item will always return a succesfull type-check.
  deriving (Eq, Ord, Typeable, Show)

checkedExpr :: TyChkExpr a o -> a
checkedExpr o = case o of
  NotTypeChecked o       -> o
  TypeChecked    o _ _   -> o
  DisableCheck   o _ _ _ -> o

instance Functor (TyChkExpr a) where
  fmap _ (NotTypeChecked   a  ) = NotTypeChecked a
  fmap f (TypeChecked  a b c  ) = TypeChecked  a (fmap f b) c
  fmap f (DisableCheck a b c d) = DisableCheck a (fmap f b) (f c) d

fmapCheckedValueExpr :: (a -> b) -> TyChkExpr a o -> TyChkExpr b o
fmapCheckedValueExpr f a = case a of
  NotTypeChecked   a   -> NotTypeChecked (f a)
  TypeChecked  a b c   -> TypeChecked  (f a) b c
  DisableCheck a b c d -> DisableCheck (f a) b c d

instance (NFData o, NFData a) => NFData (TyChkExpr a o) where
  rnf (NotTypeChecked   a  ) = deepseq a ()
  rnf (TypeChecked  a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (DisableCheck a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance (HasNullValue o, HasNullValue a) => HasNullValue (TyChkExpr a o) where
  nullValue = NotTypeChecked nullValue
  testNull (NotTypeChecked a) = testNull a
  testNull _ = False

instance HasLocation a => HasLocation (TyChkExpr a o) where
  getLocation a     = case a of
    NotTypeChecked a         -> getLocation a
    TypeChecked    a _   loc -> getLocation a <> loc
    DisableCheck   a _ _ loc -> getLocation a <> loc
  setLocation a loc = case a of
    NotTypeChecked a       -> NotTypeChecked (setLocation a loc)
    TypeChecked    a b   _ -> TypeChecked  a b loc
    DisableCheck   a b c _ -> DisableCheck a b c loc
  delLocation a     = case a of
    NotTypeChecked a       -> NotTypeChecked (delLocation a)
    TypeChecked    a b   _ -> TypeChecked (delLocation a) (delLocation b) LocationUnknown
    DisableCheck   a b c _ -> DisableCheck a b c LocationUnknown

instance (PPrintable o, PPrintable a) => PPrintable (TyChkExpr a o) where
  pPrint a = case a of
    NotTypeChecked a        -> pPrint a
    TypeChecked    a expr _ -> pInline [pPrint a, pString ": ", pPrint expr]
    DisableCheck   a  _ _ _ -> pInline [pPrint a]

----------------------------------------------------------------------------------------------------

-- | This node can be found in a few different syntactic structures. When a name or function or
-- expression is followed by a colon and some type checking information, this node is used for that
-- purpose.
data AST_TyChk a o
  = AST_NotChecked a
  | AST_Checked    a (Com ()) (AST_Arith o) Location
  deriving (Eq, Ord, Typeable, Show)

checkedAST :: AST_TyChk a o -> a
checkedAST a = case a of { AST_NotChecked a -> a; AST_Checked a _ _ _ -> a; }

astTyChkDelLocWith :: (a -> a) -> AST_TyChk a o -> AST_TyChk a o
astTyChkDelLocWith del a = case a of
  AST_NotChecked a       -> AST_NotChecked (del a)
  AST_Checked    a b c _ -> AST_Checked    (del a) b (delLocation c) LocationUnknown

instance Functor (AST_TyChk o) where
  fmap _ (AST_NotChecked a      ) = AST_NotChecked a
  fmap f (AST_Checked    a b c d) = AST_Checked    a b (fmap f c) d

fmapCheckedValueAST :: (a -> b) -> AST_TyChk a o -> AST_TyChk b o
fmapCheckedValueAST f a = case a of
  AST_NotChecked a       -> AST_NotChecked (f a)
  AST_Checked    a b c d -> AST_Checked    (f a) b c d

instance (NFData o, NFData a) => NFData (AST_TyChk a o) where
  rnf (AST_NotChecked    a) = deepseq a ()
  rnf (AST_Checked a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance (HasNullValue o, HasNullValue a) => HasNullValue (AST_TyChk a o) where
  nullValue = AST_NotChecked nullValue
  testNull (AST_NotChecked  a  ) = testNull a
  testNull (AST_Checked _ _ a _) = testNull a

instance (PPrintable o, PPrintable a) => PPrintable (AST_TyChk a o) where
  pPrint a = case a of
    AST_NotChecked a          -> pPrint a
    AST_Checked    a coms expr _ -> pInline $
      [ pPrint a
      , pPrintComWith (\ () -> pString "::") coms
      , pPrint expr
      ]

instance HasLocation a => HasLocation (AST_TyChk a o) where
  getLocation a     = case a of
    AST_NotChecked a         -> getLocation a
    AST_Checked    a _ _ loc -> getLocation a <> loc
  setLocation a loc = case a of
    AST_NotChecked a         -> AST_NotChecked (setLocation a loc)
    AST_Checked    a b c _   -> AST_Checked a b c loc
  delLocation       = astTyChkDelLocWith delLocation

instance (HasRandGen o, HasRandGen a) => HasRandGen (AST_TyChk a o) where
  randO    = countNode $ AST_NotChecked <$> randO
  --randChoice = randChoiceList [AST_NotChecked <$> randO, return AST_Checked <*> randO <*> randO <*> randO <*> no]
  defaultO = AST_NotChecked <$> defaultO

tyChkToInterm :: (b -> [a]) -> AST_TyChk b o -> [TyChkExpr a o]
tyChkToInterm ti a = case a of
  AST_NotChecked a         -> NotTypeChecked <$> ti a
  AST_Checked    a _ b loc -> [TypeChecked] <*> ti a <*> toInterm b <*> [loc]

tyChkFromInterm :: (a -> [b]) -> TyChkExpr a o -> [AST_TyChk b o]
tyChkFromInterm fi a = case a of
  NotTypeChecked a         -> AST_NotChecked <$> fi a
  TypeChecked    a b   loc -> [AST_Checked] <*> fi a <*> [Com ()] <*> fromInterm b <*> [loc]
  DisableCheck   a b _ loc -> [AST_Checked] <*> fi a <*> [Com ()] <*> fromInterm b <*> [loc]

----------------------------------------------------------------------------------------------------

-- | A list of function parameters (arguments) to a function in an object representing a function
-- expression.
data ParamListExpr o = ParamListExpr (TyChkExpr [ParamExpr o] o) Location
  deriving (Eq, Ord, Typeable, Show)

instance Functor ParamListExpr where
  fmap f (ParamListExpr a loc) =
    ParamListExpr (fmapCheckedValueExpr (fmap (fmap f)) $ fmap f a) loc

instance NFData o => NFData (ParamListExpr o) where { rnf (ParamListExpr a b) = deepseq a $! deepseq b () }

instance HasNullValue (ParamListExpr o) where
  nullValue = ParamListExpr (NotTypeChecked []) LocationUnknown
  testNull (ParamListExpr (NotTypeChecked []) _) = True
  testNull _ = False

instance HasLocation (ParamListExpr o) where
  getLocation (ParamListExpr _ loc)     = loc
  setLocation (ParamListExpr a _  ) loc = ParamListExpr a loc
  delLocation (ParamListExpr a _  )     = ParamListExpr a LocationUnknown

instance PPrintable o => PPrintable (ParamListExpr o) where { pPrint (ParamListExpr lst _) = pPrint lst }

getTypeCheckList :: ParamListExpr o -> [ParamExpr o]
getTypeCheckList (ParamListExpr tychk _) = tyChkItem tychk 

----------------------------------------------------------------------------------------------------

-- | 'ParamExpr' is a part of the Dao language semantics, and is also used in the the 'CallableCode'
-- data type when evaluating parameters to be passed to the callable code function execution. The
-- boolean parameter here indicates whether or not the parameter should be passed by reference.
data ParamExpr o = ParamExpr Bool (TyChkExpr Name o) Location deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (ParamExpr o) where
  rnf (ParamExpr       a b c) = deepseq a $! deepseq b $! deepseq c ()

instance HasLocation (ParamExpr o) where
  getLocation (ParamExpr _ _ loc)     = loc
  setLocation (ParamExpr a b _  ) loc = ParamExpr a b loc
  delLocation (ParamExpr a b _  )     = ParamExpr a b LocationUnknown

instance PPrintable o => PPrintable (ParamExpr o) where
  pPrint (ParamExpr byRef tychk _) = when byRef (pString "$") >> pPrint tychk

instance PPrintable o => PPrintable [ParamExpr o] where { pPrint lst = pList_ "(" ", " ")" (fmap pPrint lst) }

----------------------------------------------------------------------------------------------------

data AST_Param o
  = AST_NoParams
  | AST_Param (Maybe [Comment]) (AST_TyChk Name o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_Param o) where
  rnf  AST_NoParams     = ()
  rnf (AST_Param a b c) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue (AST_Param o) where
  nullValue = AST_NoParams
  testNull AST_NoParams = True
  testNull _ = False

instance HasLocation (AST_Param o) where
  getLocation a     = case a of
    AST_NoParams      -> LocationUnknown
    AST_Param _ _ loc -> loc
  setLocation a loc = case a of
    AST_NoParams    -> AST_NoParams
    AST_Param a b _ -> AST_Param a b loc
  delLocation a     = case a of
    AST_NoParams    -> AST_NoParams
    AST_Param a b _ -> AST_Param a (astTyChkDelLocWith delLocation b) LocationUnknown

instance PPrintable o => PPrintable (AST_Param o) where
  pPrint o = case o of
    AST_NoParams            -> return ()
    AST_Param mcoms tychk _ -> pInline $
      [ maybe (return ()) (\coms -> pString "$" >> pPrint coms) mcoms
      , pPrint tychk
      ]

instance PPrintable o => PPrintable [Com (AST_Param o)] where
  pPrint lst = pList_ "(" ", " ")" (fmap pPrint lst)

----------------------------------------------------------------------------------------------------

instance HasRandGen o => HasRandGen (AST_Param o) where
  randO    = countNode $ return AST_Param <*> randO <*> randO <*> no
  defaultO = return AST_Param <*> defaultO <*> defaultO <*> no

instance HasRandGen o => HasRandGen [Com (AST_Param o)] where
  randO    = recurse $ depthLimitedInt 8 >>= \x -> randListOf 0 x scrambO
  defaultO = defaultList 0 1

instance Intermediate (ParamExpr o) (AST_Param o) where
  toInterm   a = case a of
    AST_NoParams      -> []
    AST_Param a b loc ->
      [ParamExpr] <*> [maybe False (const True) a]     <*> tyChkToInterm   return b <*> [loc]
  fromInterm o = case o of
    ParamExpr a b loc ->
      [AST_Param] <*> [if a then Just [] else Nothing] <*> tyChkFromInterm return b <*> [loc]

instance Intermediate [ParamExpr o] [Com (AST_Param o)] where
  toInterm   ax = [ax >>= toInterm . unComment]
  fromInterm ax = [ax >>= fmap Com . fromInterm]

----------------------------------------------------------------------------------------------------

data AST_ParamList o
  = AST_ParamList (AST_TyChk [Com (AST_Param o)] o) Location
  deriving (Eq, Ord, Typeable, Show)

instance Functor AST_ParamList where
  fmap f (AST_ParamList a loc) =
    AST_ParamList (fmapCheckedValueAST (fmap (fmap (fmap f))) $ fmap f a) loc

instance NFData o => NFData (AST_ParamList o) where { rnf (AST_ParamList a b) = deepseq a $! deepseq b () }

instance HasNullValue o => HasNullValue (AST_ParamList o) where
  nullValue = AST_ParamList nullValue LocationUnknown
  testNull (AST_ParamList a _) = testNull a

instance HasLocation (AST_ParamList o) where
  getLocation (AST_ParamList _ loc)     = loc
  setLocation (AST_ParamList a _  ) loc = AST_ParamList a loc
  delLocation (AST_ParamList a _  )     = AST_ParamList (astTyChkDelLocWith (fmap delLocation) a) LocationUnknown

instance PPrintable o => PPrintable (AST_ParamList o) where
  pPrint (AST_ParamList lst _) = pInline [pPrint lst]

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_ParamList o) where
  randO    = countNode $ return AST_ParamList <*> randO <*> no
  defaultO = return $ AST_ParamList nullValue LocationUnknown

instance Intermediate (ParamListExpr o) (AST_ParamList o) where
  toInterm   (AST_ParamList ox loc) = [ParamListExpr] <*> tyChkToInterm   toInterm   ox <*> [loc]
  fromInterm (ParamListExpr ox loc) = [AST_ParamList] <*> tyChkFromInterm fromInterm ox <*> [loc]

----------------------------------------------------------------------------------------------------

data RuleFuncExpr o
  = LambdaExpr    (ParamListExpr o) (CodeBlock o) Location
  | FuncExpr Name (ParamListExpr o) (CodeBlock o) Location
  | RuleExpr      (RuleHeadExpr  o) (CodeBlock o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (RuleFuncExpr o) where
  rnf (LambdaExpr a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (FuncExpr   a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (RuleExpr   a b c  ) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue (RuleFuncExpr o) where
  nullValue = LambdaExpr nullValue nullValue LocationUnknown
  testNull (RuleExpr a b _) = testNull a && testNull b
  testNull _                = False

instance HasLocation (RuleFuncExpr o) where
  getLocation o = case o of
    LambdaExpr _ _   o -> o
    FuncExpr   _ _ _ o -> o
    RuleExpr   _ _   o -> o
  setLocation o loc = case o of
    LambdaExpr a b   _ -> LambdaExpr a b   loc
    FuncExpr   a b c _ -> FuncExpr   a b c loc
    RuleExpr   a b   _ -> RuleExpr   a b   loc
  delLocation o = case o of
    LambdaExpr a b   _ -> LambdaExpr (delLocation a) (delLocation b) LocationUnknown
    FuncExpr   a b c _ -> FuncExpr a (delLocation b) (delLocation c) LocationUnknown
    RuleExpr   a b   _ -> RuleExpr a (delLocation b)                 LocationUnknown

instance PPrintable o => PPrintable (RuleFuncExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

data AST_RuleFunc o
  = AST_Lambda              (Com (AST_ParamList  o)) (AST_CodeBlock o) Location
  | AST_Func [Comment] Name (Com (AST_ParamList  o)) (AST_CodeBlock o) Location
  | AST_Rule                (Com (AST_RuleHeader o)) (AST_CodeBlock o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_RuleFunc o) where
  rnf (AST_Lambda a b c    ) = deepseq a $! deepseq b $! deepseq c () 
  rnf (AST_Func   a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e ()
  rnf (AST_Rule   a b c    ) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue o => HasNullValue (AST_RuleFunc o) where
  nullValue = AST_Lambda nullValue nullValue LocationUnknown
  testNull (AST_Lambda a b _) = testNull a && testNull b
  testNull _                  = False

instance HasLocation (AST_RuleFunc o) where
  getLocation o = case o of
    AST_Lambda _ _     o -> o
    AST_Func   _ _ _ _ o -> o
    AST_Rule   _ _     o -> o
  setLocation o loc = case o of
    AST_Lambda a b     _ -> AST_Lambda a b     loc
    AST_Func   a b c d _ -> AST_Func   a b c d loc
    AST_Rule   a b     _ -> AST_Rule   a b     loc
  delLocation o = case o of                            
    AST_Lambda a b     _ -> AST_Lambda (delLocation  a) (delLocation  b) LocationUnknown
    AST_Func   a b c d _ -> AST_Func a b  (delLocation  c) (delLocation  d) LocationUnknown
    AST_Rule   a b     _ -> AST_Rule   (delLocation  a) (delLocation  b) LocationUnknown

instance PPrintable o => PPrintable (AST_RuleFunc o) where
  pPrint expr = case expr of
    AST_Lambda         ccNmx   xcObjXp     _ ->
      pPrintSubBlock (pInline [pString "function", pPrintComWith pPrint ccNmx]) xcObjXp
    AST_Func     co nm ccNmx   xcObjXp     _ ->
      pClosure (pInline [pString "function ", pPrint co, pPrint nm, pPrint ccNmx]) "{" "}" [pPrint xcObjXp]
    AST_Rule           ccNmx   xcObjXp     _ -> pClosure (pPrint ccNmx) "{" "}" [pPrint xcObjXp]

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RuleFunc o) where
  randO      = recurse $ countNode $ runRandChoice
  randChoice = randChoiceList $
    [ scramble $ return AST_Lambda <*> randO <*> randO <*> no
    , scramble $ return AST_Func   <*> randO <*> randO <*> randO <*> randO <*> no
    , scramble $ return AST_Rule   <*> randO <*> randO <*> no
    ]
  defaultO      = runDefaultChoice
  defaultChoice = randChoiceList $
    [ scramble $ return AST_Lambda <*> defaultO <*> defaultO <*> no
    , scramble $ return AST_Func   <*> defaultO <*> defaultO <*> defaultO <*> defaultO <*> no
    , scramble $ return AST_Rule   <*> defaultO <*> defaultO <*> no
    ]

instance Intermediate (RuleFuncExpr o) (AST_RuleFunc o) where
  toInterm ast = case ast of
    AST_Lambda a b   loc -> [LambdaExpr]       <*> uc0 a <*> ti b <*> [loc]
    AST_Func _ a b c loc -> [FuncExpr] <*> [a] <*> uc0 b <*> ti c <*> [loc]
    AST_Rule   a b   loc -> [RuleExpr]         <*> uc0 a <*> ti b <*> [loc]
  fromInterm o = case o of
    LambdaExpr a b   loc -> [AST_Lambda]                <*> nc0 a <*> fi b <*> [loc]
    FuncExpr   a b c loc -> [AST_Func] <*> [[]] <*> [a] <*> nc0 b <*> fi c <*> [loc]
    RuleExpr   a b   loc -> [AST_Rule]                  <*> nc0 a <*> fi b <*> [loc]

----------------------------------------------------------------------------------------------------

data RuleHeadExpr o
  = RuleStringExpr  UStr        Location
  | RuleHeadExpr [AssignExpr o] Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance HasNullValue (RuleHeadExpr o) where
  nullValue = RuleStringExpr nil LocationUnknown
  testNull (RuleStringExpr a _) = a==nil
  testNull _ = False

instance HasLocation (RuleHeadExpr o) where
  getLocation o     = case o of
    RuleStringExpr _ o -> o
    RuleHeadExpr   _ o -> o
  setLocation o loc = case o of
    RuleStringExpr o _ -> RuleStringExpr o loc
    RuleHeadExpr   o _ -> RuleHeadExpr o loc
  delLocation o     = case o of
    RuleStringExpr o _ -> RuleStringExpr o LocationUnknown
    RuleHeadExpr   o _ -> RuleHeadExpr (fmap delLocation o) LocationUnknown

instance NFData o => NFData (RuleHeadExpr o) where
  rnf (RuleStringExpr a b) = deepseq a $! deepseq b ()
  rnf (RuleHeadExpr     a b) = deepseq a $! deepseq b ()

----------------------------------------------------------------------------------------------------

data AST_RuleHeader o
  = AST_NullRules  [Comment]  Location
  | AST_RuleString (Com UStr) Location
  | AST_RuleHeader [Com (AST_Assign o)] Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_RuleHeader o) where
  rnf (AST_NullRules  a b) = deepseq a $! deepseq b ()
  rnf (AST_RuleString a b) = deepseq a $! deepseq b ()
  rnf (AST_RuleHeader a b) = deepseq a $! deepseq b ()

instance HasNullValue (AST_RuleHeader o) where
  nullValue = AST_NullRules [] LocationUnknown
  testNull (AST_NullRules _ _) = True
  testNull _ = False

instance HasLocation (AST_RuleHeader o) where
  getLocation o     = case o of
    AST_NullRules  _ o -> o
    AST_RuleString _ o -> o
    AST_RuleHeader _ o -> o
  setLocation o loc = case o of
    AST_NullRules  a _ -> AST_NullRules  a loc
    AST_RuleString a _ -> AST_RuleString a loc
    AST_RuleHeader a _ -> AST_RuleHeader a loc
  delLocation o     = case o of
    AST_NullRules  a _ -> AST_NullRules  a LocationUnknown
    AST_RuleString a _ -> AST_RuleString a LocationUnknown
    AST_RuleHeader a _ -> AST_RuleHeader (fmap delLocation a) LocationUnknown

instance PPrintable o => PPrintable (AST_RuleHeader o) where
  pPrint o = case o of
    AST_NullRules  coms _ -> pInline [pString "rule(", pPrint coms, pString ")"]
    AST_RuleString r    _ -> pInline [pString "rule ", pPrintComWith pShow r, pString " "]
    AST_RuleHeader ruls _ -> pList (pString "rule") "(" ", " ")" (fmap pPrint ruls)

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_RuleHeader o) where
  randO      = countNode $ runRandChoice
  randChoice = randChoiceList $
    [ return AST_RuleHeader <*> randList 0 3 <*> no
    , return AST_RuleString <*> randO   <*> no
    , return AST_NullRules  <*> scrambO <*> no
    ]
  defaultO      = runDefaultChoice
  defaultChoice = randChoiceList $
    [ return AST_NullRules  <*> defaultO <*> no
    , return AST_RuleString <*> defaultO <*> no
    ]

instance Intermediate (RuleHeadExpr o) (AST_RuleHeader o) where
  toInterm   o = case o of
    AST_NullRules  _ loc -> [RuleHeadExpr              []     loc]
    AST_RuleString o loc -> [RuleStringExpr (unComment o)     loc]
    AST_RuleHeader o loc -> [RuleHeadExpr] <*> [o>>=uc0] <*> [loc]
  fromInterm o = case o of
    RuleHeadExpr   [] loc -> [AST_NullRules               []     loc]
    RuleStringExpr o  loc -> [AST_RuleString       (Com   o)     loc]
    RuleHeadExpr   o  loc -> [AST_RuleHeader] <*> [o>>=nc0] <*> [loc]

----------------------------------------------------------------------------------------------------

-- | Defined such that the instantiation of 'CodeBlock' into the 'Executable' class executes each
-- 'ScriptExpr' in the 'CodeBlock', one after the other. Execution does not
-- occur within a 'execNested' because many other expressions which execute 'CodeBlock's,
-- especially 'TryCatch' expressions and 'ForLoop's need to be able to choose
-- when the stack is pushed so they can define temporary local variables.
newtype CodeBlock o = CodeBlock { codeBlock :: [ScriptExpr o] }
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (CodeBlock o) where { rnf (CodeBlock a) = deepseq a () }

instance Monoid (CodeBlock o) where
  mempty      = CodeBlock []
  mappend a b = CodeBlock (mappend (codeBlock a) (codeBlock b))

instance HasNullValue (CodeBlock o) where
  nullValue = mempty
  testNull (CodeBlock []) = True
  testNull _ = False

instance HasLocation (CodeBlock o) where
  getLocation o = case codeBlock o of
    [] -> LocationUnknown
    [o] -> getLocation o
    o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox))
  setLocation o _ = o
  delLocation o = CodeBlock (fmap delLocation (codeBlock o))

instance PPrintable o => PPrintable (CodeBlock o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

-- | This node in the AST typically represents the list of 'AST_Script' expressions found between
-- curly-brackets in expressions like "if" and "else" statement, "for" statements and "while"
-- statements, "with" satements, "try" and "catch" statements and function declrataions.
newtype AST_CodeBlock o = AST_CodeBlock{ getAST_CodeBlock :: [AST_Script o] }
  deriving (Eq, Ord, Typeable, Show, Functor)
  -- A code block is never standing on it's own, it is always part of a larger expression, so there
  -- is no 'Dao.Token.Location' parameter for 'AST_CodeBlock'.

instance Monoid (AST_CodeBlock o) where
  mempty      = AST_CodeBlock []
  mappend a b = AST_CodeBlock (mappend (getAST_CodeBlock a) (getAST_CodeBlock b))

instance NFData o => NFData (AST_CodeBlock o) where { rnf (AST_CodeBlock a) = deepseq a () }

instance HasNullValue (AST_CodeBlock o) where
  nullValue = AST_CodeBlock []
  testNull (AST_CodeBlock a) = null a

instance HasLocation (AST_CodeBlock o) where                                      
  getLocation o = case getAST_CodeBlock o of
    [] -> LocationUnknown
    [o] -> getLocation o
    o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox))
  setLocation o _ = o
  delLocation o = AST_CodeBlock (fmap delLocation (getAST_CodeBlock o))

-- 'pPrintComWith' wasn't good enough for this, because the comments might occur after the header
-- but before the opening bracket.
pPrintComCodeBlock :: PPrintable o => PPrint -> Com (AST_CodeBlock o) -> PPrint
pPrintComCodeBlock header c = case c of
  Com          c    -> run [] c []
  ComBefore bx c    -> run bx c []
  ComAfter     c ax -> run [] c ax
  ComAround bx c ax -> run bx c ax
  where
    run :: PPrintable o => [Comment] -> (AST_CodeBlock o) -> [Comment] -> PPrint
    run before cx after = case getAST_CodeBlock cx of
      [] -> header >> pInline (map pPrint before) >> pString " {}" >> pInline (map pPrint after)
      cx -> do
        pClosure (header >> pInline (map pPrint before)) " { " " }" (map (pGroup True . pPrint) cx)
        pInline (map pPrint after)

pPrintSubBlock :: PPrintable o => PPrint -> (AST_CodeBlock o) -> PPrint
pPrintSubBlock header px = pPrintComCodeBlock header (Com px)

instance PPrintable o => PPrintable (AST_CodeBlock o) where { pPrint o = mapM_ pPrint (getAST_CodeBlock o) }

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_CodeBlock o) where
  randO    = countNode $ AST_CodeBlock . concat <$> sequence [return <$> scrambO, depthLimitedInt 16 >>= \x -> randList 0 x]
  defaultO = return $ AST_CodeBlock []

instance Intermediate (CodeBlock o) (AST_CodeBlock o) where
  toInterm   (AST_CodeBlock ast) = [CodeBlock     $ ast >>= toInterm  ]
  fromInterm (CodeBlock     obj) = [AST_CodeBlock $ obj >>= fromInterm]

----------------------------------------------------------------------------------------------------

data IfExpr o = IfExpr (ParenExpr o) (CodeBlock o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (IfExpr o) where { rnf (IfExpr a b c) = deepseq a $! deepseq b $! deepseq c () }

instance HasNullValue (IfExpr o) where
  nullValue = IfExpr nullValue nullValue LocationUnknown
  testNull (IfExpr a b _) = testNull a && testNull b

instance HasLocation (IfExpr o) where
  getLocation (IfExpr _ _ loc)     = loc
  setLocation (IfExpr a b _  ) loc = IfExpr a b loc
  delLocation (IfExpr a b _  )     = IfExpr (delLocation a) (delLocation b) LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_If o = AST_If (Com (AST_Paren o)) (AST_CodeBlock o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_If o) where { rnf (AST_If a b c) = deepseq a $! deepseq b $! deepseq c () }

instance HasLocation (AST_If o) where
  getLocation (AST_If _ _ loc)     = loc
  setLocation (AST_If a b _  ) loc = AST_If a b loc
  delLocation (AST_If a b _  )     = AST_If (delLocation a) (delLocation b) LocationUnknown

instance HasNullValue (AST_If o) where
  nullValue = AST_If nullValue nullValue LocationUnknown
  testNull (AST_If a b _) = testNull a && testNull b

instance PPrintable o => PPrintable (AST_If o) where
  pPrint (AST_If ifn thn _) =
    pClosure (pString "if" >> pPrint ifn) "{" "}" [pPrint thn]

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_If o) where
  randO    = countNode $ return AST_If <*> randO <*> randO <*> no
  defaultO = return AST_If <*> defaultO <*> defaultO <*> no

instance Intermediate (IfExpr o) (AST_If o) where
  toInterm   (AST_If a b loc) = [IfExpr] <*> uc0 a <*> ti b <*> [loc]
  fromInterm (IfExpr a b loc) = [AST_If] <*> nc0 a <*> fi b <*> [loc]

----------------------------------------------------------------------------------------------------

data ElseExpr o = ElseExpr (IfExpr o) Location deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (ElseExpr o) where { rnf (ElseExpr   a b  ) = deepseq a $! deepseq b $! () }

instance HasNullValue (ElseExpr o) where
  nullValue = ElseExpr nullValue LocationUnknown
  testNull (ElseExpr a _) = testNull a

instance HasLocation (ElseExpr o) where
  getLocation (ElseExpr _ loc)     = loc
  setLocation (ElseExpr a _  ) loc = ElseExpr a loc
  delLocation (ElseExpr a _  )     = ElseExpr (delLocation a) LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_Else o = AST_Else (Com ()) (AST_If o) Location deriving (Eq, Ord, Typeable, Show, Functor)
  -- ^ @/**/ else /**/ if /**/ obj /**/ {}@

instance NFData o => NFData (AST_Else o) where { rnf (AST_Else a b c) = deepseq a $! deepseq b $! deepseq c () }

instance HasNullValue (AST_Else o) where
  nullValue = AST_Else nullValue nullValue LocationUnknown
  testNull (AST_Else a b _) = testNull a && testNull b

instance HasLocation (AST_Else o) where
  getLocation (AST_Else _ _ loc)     = loc
  setLocation (AST_Else a b _  ) loc = AST_Else a b loc
  delLocation (AST_Else a b _  )     = AST_Else a (delLocation b) LocationUnknown

instance PPrintable o => PPrintable (AST_Else o) where
  pPrint (AST_Else coms (AST_If ifn thn _) _) =
    pClosure (pPrintComWith (\ () -> pString "else ") coms >> pString "if" >> pPrint ifn) "{" "}" [pPrint thn]

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Else o) where
  randO    = countNode $ return AST_Else <*> randO <*> randO <*> no
  defaultO = return AST_Else <*> defaultO <*> defaultO <*> no

instance Intermediate (ElseExpr o) (AST_Else o) where
  toInterm   (AST_Else _ a loc) = [ElseExpr]              <*> ti a <*> [loc]
  fromInterm (ElseExpr   a loc) = [AST_Else] <*> [Com ()] <*> fi a <*> [loc]

----------------------------------------------------------------------------------------------------

data IfElseExpr o = IfElseExpr (IfExpr o) [ElseExpr o] (Maybe (LastElseExpr o)) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (IfElseExpr o) where
  rnf (IfElseExpr a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasNullValue (IfElseExpr o) where
  nullValue = IfElseExpr nullValue [] Nothing LocationUnknown
  testNull (IfElseExpr a [] Nothing _) = testNull a
  testNull _ = False

instance HasLocation (IfElseExpr o) where
  getLocation (IfElseExpr _ _ _ loc)     = loc
  setLocation (IfElseExpr a b c _  ) loc = IfElseExpr a b c loc
  delLocation (IfElseExpr a b c _  )     =
    IfElseExpr (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_IfElse o = AST_IfElse (AST_If o) [AST_Else o] (Maybe (AST_LastElse o)) Location
  -- ^ @if /**/ obj /**/ {} /**/ else /**/ if /**/ obj /**/ {} /**/ else {}@
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_IfElse o) where
  rnf (AST_IfElse a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasNullValue (AST_IfElse o) where
  nullValue = AST_IfElse nullValue [] Nothing LocationUnknown
  testNull (AST_IfElse a [] Nothing _) = testNull a
  testNull _ = False

instance HasLocation (AST_IfElse o) where
  getLocation (AST_IfElse _ _ _ loc)     = loc
  setLocation (AST_IfElse a b c _  ) loc = AST_IfElse a b c loc
  delLocation (AST_IfElse a b c _  )     = AST_IfElse (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown

instance PPrintable o => PPrintable (AST_IfElse o) where
  pPrint (AST_IfElse ifn els deflt _) = do
    pPrint ifn >> pNewLine
    mapM_ pPrint els >> pNewLine
    maybe (return ()) pPrint deflt

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_IfElse o) where
  randO    = countNode $ depthLimitedInt 8 >>= \x ->
    return AST_IfElse <*> randO <*> randList 0 x <*> randO <*> no
  defaultO = return AST_IfElse <*> defaultO <*> defaultList 0 1 <*> randO <*> no

instance Intermediate (IfElseExpr o) (AST_IfElse o) where
  toInterm   (AST_IfElse a b c loc) =
    [IfElseExpr] <*> ti a <*> [b>>=ti] <*> um1 c <*> [loc]
  fromInterm (IfElseExpr a b c loc) =
    [AST_IfElse] <*> fi a <*> [b>>=fi] <*> nm1 c <*> [loc]

----------------------------------------------------------------------------------------------------

data LastElseExpr o = LastElseExpr (CodeBlock o) Location
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (LastElseExpr o) where
  rnf (LastElseExpr a b) = deepseq a $! deepseq b ()

instance HasNullValue (LastElseExpr o) where
  nullValue = LastElseExpr nullValue LocationUnknown
  testNull (LastElseExpr o _) = testNull o

instance HasLocation (LastElseExpr o) where
  getLocation (LastElseExpr _ loc)     = loc
  setLocation (LastElseExpr a _  ) loc = LastElseExpr a loc
  delLocation (LastElseExpr a _  )     = LastElseExpr (delLocation a) LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_LastElse o = AST_LastElse (Com ()) (AST_CodeBlock o) Location
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (AST_LastElse o) where
  rnf (AST_LastElse a b c) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue (AST_LastElse o) where
  nullValue = AST_LastElse (Com ()) nullValue LocationUnknown
  testNull (AST_LastElse a b _) = testNull a && testNull b

instance HasLocation (AST_LastElse o) where
  getLocation (AST_LastElse _ _ loc)     = loc
  setLocation (AST_LastElse a b _  ) loc = AST_LastElse a b loc
  delLocation (AST_LastElse a b _  )     = AST_LastElse a (delLocation b) LocationUnknown

instance PPrintable o => PPrintable (AST_LastElse o) where
  pPrint (AST_LastElse coms code _) =
    pClosure (pPrintComWith (\ () -> pString "else") coms) "{" "}" [pPrint code]

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_LastElse o) where
  randO         = countNode $ return AST_LastElse <*> randO <*> randO <*> no
  randChoice    = randChoiceList [randO]
  defaultO      = return AST_LastElse <*> defaultO <*> defaultO <*> no
  defaultChoice = randChoiceList [defaultO]

instance Intermediate (LastElseExpr o) (AST_LastElse o) where
  toInterm   (AST_LastElse _ o loc) = [LastElseExpr] <*>              toInterm   o <*> [loc]
  fromInterm (LastElseExpr   o loc) = [AST_LastElse] <*> [Com ()] <*> fromInterm o <*> [loc]

----------------------------------------------------------------------------------------------------

data CatchExpr o = CatchExpr (ParamExpr o) (CodeBlock o) Location
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (CatchExpr o) where
  rnf (CatchExpr a b c) = deepseq a $! deepseq b $! deepseq c ()

instance HasLocation (CatchExpr o) where
  getLocation (CatchExpr _ _ loc)     = loc
  setLocation (CatchExpr a b _  ) loc = CatchExpr a b loc
  delLocation (CatchExpr a b _  )     = CatchExpr (delLocation a) (delLocation b) LocationUnknown

----------------------------------------------------------------------------------------------------

data AST_Catch o = AST_Catch [Comment] (Com (AST_Param o)) (AST_CodeBlock o) Location
  deriving (Eq, Ord, Show, Typeable, Functor)

instance NFData o => NFData (AST_Catch o) where
  rnf (AST_Catch a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()

instance HasLocation (AST_Catch o) where
  getLocation (AST_Catch _ _ _ loc)     = loc
  setLocation (AST_Catch a b c _  ) loc = AST_Catch a b c loc
  delLocation (AST_Catch a b c _  )     = AST_Catch a (delLocation b) (delLocation c) LocationUnknown

instance PPrintable o => PPrintable (AST_Catch o) where
  pPrint (AST_Catch coms param code _) = pPrint coms >>
    pClosure (pString "catch " >> pPrint param) "{" "}" [pPrint code]

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Catch o) where
  randO         = countNode $ return AST_Catch <*> randO <*> randO <*> randO <*> no
  randChoice    = randChoiceList [randO]
  defaultO      = return AST_Catch <*> defaultO <*> defaultO <*> defaultO <*> no
  defaultChoice = randChoiceList [defaultO]

instance Intermediate (CatchExpr o) (AST_Catch o) where
  toInterm   (AST_Catch _ a b loc) = [CatchExpr]          <*> uc0 a <*> ti b <*> [loc]
  fromInterm (CatchExpr   a b loc) = [AST_Catch] <*> [[]] <*> nc0 a <*> fi b <*> [loc]

----------------------------------------------------------------------------------------------------

newtype WhileExpr o = WhileExpr (IfExpr o) deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (WhileExpr o)  where { rnf (WhileExpr (IfExpr a b c)) = deepseq a $! deepseq b $! deepseq c () }

instance HasNullValue (WhileExpr o) where
  nullValue = WhileExpr nullValue
  testNull (WhileExpr a) = testNull a

instance HasLocation (WhileExpr o) where
  getLocation (WhileExpr a)     = getLocation a
  setLocation (WhileExpr a) loc = WhileExpr (setLocation a loc)
  delLocation (WhileExpr a)     = WhileExpr (delLocation a)

----------------------------------------------------------------------------------------------------

newtype AST_While o = AST_While (AST_If o) deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_While o) where { rnf (AST_While (AST_If a b c)) = deepseq a $! deepseq b $! deepseq c () }

instance HasNullValue (AST_While o) where
  nullValue = AST_While nullValue
  testNull (AST_While a) = testNull a

instance HasLocation (AST_While o) where
  getLocation (AST_While a) = getLocation a
  setLocation (AST_While a) loc = AST_While (setLocation a loc)
  delLocation (AST_While a)     = AST_While (delLocation a)

instance PPrintable o => PPrintable (AST_While o) where
  pPrint (AST_While (AST_If ifn thn _)) =
    pClosure (pInline [pString "while", pPrint ifn]) "{" "}" [pPrint thn]

instance Intermediate (WhileExpr o) (AST_While o) where
  toInterm   (AST_While a) = WhileExpr <$> ti a
  fromInterm (WhileExpr a) = AST_While <$> fi a

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_While o)  where
  randO    = AST_While <$> randO
  defaultO = AST_While <$> defaultO

----------------------------------------------------------------------------------------------------

-- | Part of the Dao language abstract syntax tree: any expression that controls the flow of script
-- exectuion.
data ScriptExpr o
  = IfThenElse   (IfElseExpr   o)
  | WhileLoop    (WhileExpr    o)
  | RuleFuncExpr (RuleFuncExpr o)
  | EvalObject   (AssignExpr   o)                                 Location -- location of the semicolon
  | TryCatch     (CodeBlock    o) [LastElseExpr  o] [CatchExpr o] Location
  | ForLoop       Name            (RefPrefixExpr o) (CodeBlock o) Location
  | ContinueExpr  Bool            (AssignExpr    o)               Location
  | ReturnExpr    Bool            (AssignExpr    o)               Location
  | WithDoc      (ParenExpr    o) (CodeBlock     o)               Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (ScriptExpr o) where
  rnf (IfThenElse   a      ) = deepseq a ()
  rnf (WhileLoop    a      ) = deepseq a ()
  rnf (RuleFuncExpr a      ) = deepseq a ()
  rnf (EvalObject   a b    ) = deepseq a $! deepseq b ()
  rnf (TryCatch     a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (ForLoop      a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (ContinueExpr a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (ReturnExpr   a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (WithDoc      a b c  ) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue o => HasNullValue (ScriptExpr o) where
  nullValue = EvalObject nullValue LocationUnknown
  testNull (EvalObject a _) = testNull a
  testNull _ = False

instance HasLocation (ScriptExpr o) where
  getLocation o = case o of
    EvalObject   _     o -> o
    IfThenElse         o -> getLocation o
    RuleFuncExpr       o -> getLocation o
    WhileLoop          o -> getLocation o
    TryCatch     _ _ _ o -> o
    ForLoop      _ _ _ o -> o
    ContinueExpr _ _   o -> o
    ReturnExpr   _ _   o -> o
    WithDoc      _ _   o -> o
  setLocation o loc = case o of
    EvalObject   a     _ -> EvalObject   a     loc
    IfThenElse   a       -> IfThenElse   (setLocation a loc)
    WhileLoop    a       -> WhileLoop    (setLocation a loc)
    RuleFuncExpr a       -> RuleFuncExpr (setLocation a loc)
    TryCatch     a b c _ -> TryCatch     a b c loc
    ForLoop      a b c _ -> ForLoop      a b c loc
    ContinueExpr a b   _ -> ContinueExpr a b   loc
    ReturnExpr   a b   _ -> ReturnExpr   a b   loc
    WithDoc      a b   _ -> WithDoc      a b   loc
  delLocation o = case o of
    EvalObject   a     _ -> EvalObject   (delLocation a)                    LocationUnknown
    IfThenElse   a       -> IfThenElse   (delLocation a)
    WhileLoop    a       -> WhileLoop    (delLocation a)
    RuleFuncExpr a       -> RuleFuncExpr (delLocation a)
    TryCatch     a b c _ -> TryCatch     (delLocation a) (fmap delLocation b) (fmap delLocation c) LocationUnknown
    ForLoop      a b c _ -> ForLoop      a (delLocation b) (delLocation c) LocationUnknown
    ContinueExpr a b   _ -> ContinueExpr a (delLocation b)                 LocationUnknown
    ReturnExpr   a b   _ -> ReturnExpr   a (delLocation b)                 LocationUnknown
    WithDoc      a b   _ -> WithDoc      (delLocation a) (delLocation b)   LocationUnknown

----------------------------------------------------------------------------------------------------

-- | Part of the Dao language abstract syntax tree: any expression that controls the flow of script
-- exectuion.
data AST_Script o
  = AST_Comment     [Comment] 
  | AST_IfThenElse  (AST_IfElse o)
  | AST_WhileLoop   (AST_While o)
  | AST_RuleFunc    (AST_RuleFunc o)
  | AST_EvalObject  (AST_Assign o)  [Comment]                                          Location
    -- ^ @some.object.expression = for.example - equations || function(calls) /**/ ;@
  | AST_TryCatch    [Comment] (AST_CodeBlock o)   [AST_LastElse  o]  [AST_Catch     o] Location
    -- ^ @try /**/ {} /**/ else /**/ {} /**/ catch /**/ errVar /**/ {}@              
  | AST_ForLoop     (Com Name)               (Com (AST_RefPrefix o)) (AST_CodeBlock o) Location
    -- ^ @for /**/ var /**/ in /**/ objExpr /**/ {}@
  | AST_ContinueExpr Bool  [Comment]         (Com (AST_Assign    o))                   Location
    -- ^ The boolean parameter is True for a "continue" statement, False for a "break" statement.
    -- @continue /**/ ;@ or @continue /**/ if /**/ objExpr /**/ ;@
  | AST_ReturnExpr   Bool                    (Com (AST_Assign    o))                   Location
    -- ^ The boolean parameter is True for a "return" statement, False for a "throw" statement.
    -- ^ @return /**/ ;@ or @return /**/ objExpr /**/ ;@
  | AST_WithDoc      (Com (AST_Paren o))          (AST_CodeBlock o)                    Location
    -- ^ @with /**/ objExpr /**/ {}@
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (AST_Script o) where
  rnf (AST_Comment      a        ) = deepseq a ()
  rnf (AST_IfThenElse   a        ) = deepseq a ()
  rnf (AST_WhileLoop    a        ) = deepseq a ()
  rnf (AST_RuleFunc     a        ) = deepseq a ()
  rnf (AST_EvalObject   a b c    ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (AST_TryCatch     a b c d e) = deepseq a $! deepseq b $! deepseq c $! deepseq d $! deepseq e ()
  rnf (AST_ForLoop      a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (AST_ContinueExpr a b c d  ) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (AST_ReturnExpr   a b c    ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (AST_WithDoc      a b c    ) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue (AST_Script o) where
  nullValue = AST_EvalObject nullValue [] LocationUnknown
  testNull (AST_EvalObject a _ _) = testNull a
  testNull _ = False

instance HasLocation (AST_Script o) where
  getLocation o = case o of
    AST_Comment      _         -> LocationUnknown
    AST_EvalObject   _   _   o -> o
    AST_IfThenElse           o -> getLocation o
    AST_WhileLoop            o -> getLocation o
    AST_RuleFunc             o -> getLocation o
    AST_TryCatch     _ _ _ _ o -> o
    AST_ForLoop      _ _ _   o -> o
    AST_ContinueExpr _ _ _   o -> o
    AST_ReturnExpr   _ _     o -> o
    AST_WithDoc      _ _     o -> o
  setLocation o loc = case o of
    AST_Comment      a         -> AST_Comment      a
    AST_EvalObject   a b     _ -> AST_EvalObject   a b   loc
    AST_IfThenElse   a         -> AST_IfThenElse   (setLocation a loc)
    AST_WhileLoop    a         -> AST_WhileLoop    (setLocation a loc)
    AST_RuleFunc     a         -> AST_RuleFunc     (setLocation a loc)
    AST_TryCatch     a b c d _ -> AST_TryCatch     a b c d loc
    AST_ForLoop      a b c   _ -> AST_ForLoop      a b c   loc
    AST_ContinueExpr a b c   _ -> AST_ContinueExpr a b c   loc
    AST_ReturnExpr   a b     _ -> AST_ReturnExpr   a b     loc
    AST_WithDoc      a b     _ -> AST_WithDoc      a b     loc
  delLocation o = case o of
    AST_Comment      a         -> AST_Comment      a
    AST_EvalObject   a b     _ -> AST_EvalObject   (delLocation  a) b LocationUnknown
    AST_IfThenElse   a         -> AST_IfThenElse   (delLocation  a)
    AST_WhileLoop    a         -> AST_WhileLoop    (delLocation  a)
    AST_RuleFunc     a         -> AST_RuleFunc     (delLocation  a)
    AST_TryCatch     a b c d _ -> AST_TryCatch     a (delLocation b) (fmap delLocation c) (fmap delLocation d) LocationUnknown
    AST_ForLoop      a b c   _ -> AST_ForLoop      a (fmap delLocation b) (delLocation c) LocationUnknown
    AST_ContinueExpr a b c   _ -> AST_ContinueExpr a b (fmap delLocation c) LocationUnknown
    AST_ReturnExpr   a b     _ -> AST_ReturnExpr   a (fmap delLocation b) LocationUnknown
    AST_WithDoc      a b     _ -> AST_WithDoc      (fmap delLocation a) (delLocation b) LocationUnknown

instance PPrintable o => PPrintable (AST_Script o) where
  pPrint expr = pGroup True $ case expr of
    AST_Comment             coms -> mapM_ pPrint coms
    AST_EvalObject   objXp  coms                      _ ->
      pPrint objXp >> mapM_ pPrint coms >> pString ";"
    AST_IfThenElse   ifXp                          -> pPrint ifXp
    AST_WhileLoop    whileLoop                     -> pPrint whileLoop
    AST_RuleFunc     ruleOrFunc                    -> pPrint ruleOrFunc
    AST_TryCatch     coms scrpXp elsXp catchExpr _ -> do
      pClosure (pString "try" >> pPrint coms) "{" "}" [pPrint scrpXp]
      mapM_ (\o -> pPrint o >> pEndLine) elsXp
      mapM_ (\o -> pPrint o >> pEndLine) catchExpr
    AST_ForLoop      cNm      cObjXp  xcScrpXp   _ ->
      pPrintSubBlock (pString "for " >> pPrint cNm >> pString " in " >> pPrint cObjXp) xcScrpXp
    AST_ContinueExpr contin   coms    cObjXp     _ -> pWrapIndent $
      [ pString (if contin then "continue" else "break")
      , pInline (map pPrint coms)
      , case unComment cObjXp of
          AST_Eval (AST_ObjArith (AST_Object AST_Void)) -> return ()
          _ -> pString " if" >> when (precedeWithSpace cObjXp) (pString " ") >> pPrint cObjXp
      , pString ";"
      ]
    AST_ReturnExpr   retrn           cObjXp      _ -> pWrapIndent $
      [pString (if retrn then "return " else "throw "), pPrint cObjXp, pString ";"]
    AST_WithDoc      cObjXp          xcScrpXp    _ ->
      pPrintSubBlock (pString "with " >> pPrint cObjXp) xcScrpXp

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_Script o) where
  randO      = countNode $ recurse $ runRandChoice
  randChoice = randChoiceList $
    [ return AST_EvalObject   <*> randO <*> randO <*> no
    , return AST_IfThenElse   <*> randO
    , return AST_WhileLoop    <*> randO
    , return AST_RuleFunc     <*> randO
    , scramble $ depthLimitedInt 4 >>= \x -> depthLimitedInt 4 >>= \y -> 
        return AST_TryCatch <*> randO <*> randO <*> randList 0 x <*> randList 0 y <*> no
    , scramble $ return AST_ForLoop      <*> randO <*> randO <*> randO <*> no
    , scramble $ return AST_ContinueExpr <*> randO <*> randO <*> randO <*> no
    , scramble $ return AST_ReturnExpr   <*> randO <*> randO <*> no
    , scramble $ return AST_WithDoc      <*> randO <*> randO <*> no
    ]
  defaultO      = runDefaultChoice
  defaultChoice = randChoiceList $
    [ AST_IfThenElse <$> defaultO
    , AST_WhileLoop  <$> defaultO
    , AST_RuleFunc   <$> defaultO
    , return AST_TryCatch     <*> pure []  <*> defaultO <*> defaultList 0 1 <*> defaultList 0 1 <*> no
    , return AST_ContinueExpr <*> defaultO <*> defaultO <*> defaultO <*> no
    , return AST_ReturnExpr   <*> defaultO <*> defaultO <*> no
    ]

instance PPrintable o => PPrintable (ScriptExpr o) where { pPrint = pPrintInterm }

instance Intermediate (ScriptExpr o) (AST_Script o) where
  toInterm   ast = case ast of
    AST_Comment      _           -> mzero
    AST_EvalObject   a _     loc -> [EvalObject  ] <*> ti  a                     <*> [loc]
    AST_IfThenElse   a           -> [IfThenElse  ] <*> ti  a
    AST_WhileLoop    a           -> [WhileLoop   ] <*> ti  a
    AST_RuleFunc     a           -> [RuleFuncExpr] <*> ti  a
    AST_TryCatch     _ a b c loc -> [TryCatch    ] <*> ti  a <*> mapM ti b <*> mapM ti c <*> [loc]
    AST_ForLoop      a b c   loc -> [ForLoop     ] <*> uc  a <*> uc0 b <*> ti  c <*> [loc]
    AST_ContinueExpr a _ c   loc -> [ContinueExpr] <*> [a]   <*> uc0 c           <*> [loc]
    AST_ReturnExpr   a b     loc -> [ReturnExpr  ] <*> [a]   <*> uc0 b           <*> [loc]
    AST_WithDoc      a b     loc -> [WithDoc     ] <*> uc0 a <*> ti  b           <*> [loc]
  fromInterm obj = case obj of
    EvalObject   a     loc -> [AST_EvalObject  ] <*> fi  a  <*> [[]]           <*> [loc]
    IfThenElse   a         ->  AST_IfThenElse    <$> fi  a
    WhileLoop    a         ->  AST_WhileLoop     <$> fi  a
    RuleFuncExpr a         ->  AST_RuleFunc      <$> fi  a
    TryCatch     a b c loc -> [AST_TryCatch    ] <*> [[]]   <*> fi  a <*> mapM fi b <*> mapM fi c <*> [loc]
    ForLoop      a b c loc -> [AST_ForLoop     ] <*> nc  a  <*> nc0 b <*> fi  c <*> [loc]
    ContinueExpr a b   loc -> [AST_ContinueExpr] <*>    [a] <*> [[]]  <*> nc0 b <*> [loc]
    ReturnExpr   a b   loc -> [AST_ReturnExpr  ] <*>    [a] <*> nc0 b           <*> [loc]
    WithDoc      a b   loc -> [AST_WithDoc     ] <*> nc0 a  <*> fi  b           <*> [loc]
                         
----------------------------------------------------------------------------------------------------

data AttributeExpr
  = AttribDotNameExpr DotLabelExpr
  | AttribStringExpr  UStr        Location
  deriving (Eq, Ord, Show, Typeable)

instance NFData AttributeExpr where
  rnf (AttribDotNameExpr a  ) = deepseq a ()
  rnf (AttribStringExpr  a b) = deepseq a $! deepseq b ()

instance HasNullValue AttributeExpr where
  nullValue = AttribStringExpr nil LocationUnknown
  testNull (AttribStringExpr a _) = a==nil
  testNull _ = False

instance HasLocation AttributeExpr where
  getLocation o     = case o of
    AttribDotNameExpr   o   -> getLocation o
    AttribStringExpr  _ loc -> loc
  setLocation o loc = case o of
    AttribDotNameExpr o     -> AttribDotNameExpr (setLocation o loc)
    AttribStringExpr  o _   -> AttribStringExpr o loc
  delLocation o     = case o of
    AttribDotNameExpr o     -> AttribDotNameExpr (delLocation o)
    AttribStringExpr  o _   -> AttribStringExpr o LocationUnknown

instance PPrintable AttributeExpr where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

data AST_Attribute
  = AST_AttribDotName AST_DotLabel
  | AST_AttribString  UStr        Location
  deriving (Eq, Ord, Show, Typeable)

instance NFData AST_Attribute where
  rnf (AST_AttribDotName a  ) = deepseq a ()
  rnf (AST_AttribString  a b) = deepseq a $! deepseq b ()

instance HasNullValue AST_Attribute where
  nullValue = AST_AttribString nil LocationUnknown
  testNull (AST_AttribString a _) = a==nil
  testNull _ = False

instance HasLocation AST_Attribute where
  getLocation o     = case o of
    AST_AttribDotName   o   -> getLocation o
    AST_AttribString  _ loc -> loc
  setLocation o loc = case o of
    AST_AttribDotName o     -> AST_AttribDotName (setLocation o loc)
    AST_AttribString  o _   -> AST_AttribString o loc
  delLocation o     = case o of
    AST_AttribDotName o     -> AST_AttribDotName (delLocation o)
    AST_AttribString  o _   -> AST_AttribString o LocationUnknown

instance PPrintable AST_Attribute where
  pPrint o = case o of
    AST_AttribDotName nm    -> pPrint nm
    AST_AttribString  str _ -> pPrint str

instance HasRandGen AST_Attribute where
  randChoice = randChoiceList $
    [ AST_AttribDotName <$> randO
    , return AST_AttribString  <*> randO <*> no
    ]
  randO    = countNode $ runRandChoice
  defaultO = randO
  defaultChoice = randChoiceList [defaultO]

instance Intermediate AttributeExpr AST_Attribute where
  toInterm o   = case o of
    AST_AttribDotName a     -> AttribDotNameExpr <$> ti a
    AST_AttribString  a loc -> [AttribStringExpr a loc]
  fromInterm o = case o of
    AttribDotNameExpr a     -> AST_AttribDotName <$> fi a
    AttribStringExpr  a loc -> [AST_AttribString  a loc]

----------------------------------------------------------------------------------------------------

data TopLevelEventType
  = BeginExprType | EndExprType | ExitExprType
  deriving (Eq, Ord, Typeable, Enum)

instance Show TopLevelEventType where
  show t = case t of
    BeginExprType -> "BEGIN"
    EndExprType   -> "END"
    ExitExprType  -> "EXIT"

instance Read TopLevelEventType where
  readsPrec _ str = map (\t -> (t, "")) $ case str of
    "BEGIN" -> [BeginExprType]
    "END"   -> [EndExprType]
    "EXIT"  -> [ExitExprType]
    _       -> []

instance NFData TopLevelEventType where { rnf a = seq a () }

instance HasRandGen TopLevelEventType where
  randO = fmap toEnum (nextInt 3)
  defaultO = randO

----------------------------------------------------------------------------------------------------

-- | A 'TopLevelExpr' is a single declaration for the top-level of the program file. A Dao 'SourceCode'
-- is a list of these directives.
data TopLevelExpr o
  = RequireExpr AttributeExpr                   Location
  | ImportExpr  AttributeExpr     NamespaceExpr Location
  | TopScript   (ScriptExpr o)                  Location
  | EventExpr   TopLevelEventType (CodeBlock o) Location
  deriving (Eq, Ord, Typeable, Show, Functor)

instance NFData o => NFData (TopLevelExpr o) where
  rnf (RequireExpr a b  ) = deepseq a $! deepseq b ()
  rnf (ImportExpr  a b c) = deepseq a $! deepseq b $! deepseq c ()
  rnf (TopScript   a b  ) = deepseq a $! deepseq b ()
  rnf (EventExpr   a b c) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue o => HasNullValue (TopLevelExpr o) where
  nullValue = TopScript nullValue LocationUnknown
  testNull (TopScript a LocationUnknown) = testNull a
  testNull _ = False

isAttribute :: TopLevelExpr o -> Bool
isAttribute toplevel = case toplevel of { RequireExpr{} -> True; ImportExpr{} -> True; _ -> False; }

instance HasLocation (TopLevelExpr o) where
  getLocation o = case o of
    RequireExpr _   o -> o
    ImportExpr  _ _ o -> o
    TopScript   _   o -> o
    EventExpr   _ _ o -> o
  setLocation o loc = case o of
    RequireExpr a    _ -> RequireExpr a loc
    ImportExpr  a b  _ -> ImportExpr  a b loc
    TopScript   a    _ -> TopScript   a   loc
    EventExpr   a b  _ -> EventExpr   a b loc
  delLocation o = case o of
    RequireExpr a    _ -> RequireExpr (delLocation a) LocationUnknown
    ImportExpr  a b  _ -> ImportExpr  (delLocation a) (delLocation b) LocationUnknown
    TopScript   a    _ -> TopScript   (delLocation a) LocationUnknown
    EventExpr   a b  _ -> EventExpr a (delLocation b) LocationUnknown

instance PPrintable o => PPrintable (TopLevelExpr o) where { pPrint = pPrintInterm }

----------------------------------------------------------------------------------------------------

-- | A 'AST_TopLevel' is a single declaration for the top-level of the program file. A Dao 'SourceCode'
-- is a list of these directives.
data AST_TopLevel o
  = AST_Require    (Com AST_Attribute)                       Location
  | AST_Import     (Com AST_Attribute)         AST_Namespace Location
  | AST_TopScript  (AST_Script o)                            Location
  | AST_Event      TopLevelEventType [Comment] (AST_CodeBlock o) Location
  | AST_TopComment [Comment]
  deriving (Eq, Ord, Typeable, Show, Functor)

instance (HasNullValue o, HasRandGen o) => HasRandGen (AST_TopLevel o) where
  randO      = countNode $ runRandChoice
  randChoice = randChoiceList $
    [ return AST_Require   <*> randO                     <*> no
    , return AST_Import    <*> randO <*> randO           <*> no
    , return AST_TopScript <*> randO                     <*> no
    , return AST_Event     <*> randO <*> randO <*> randO <*> no
    , AST_TopComment <$> defaultO
    ]
  defaultO      = runDefaultChoice
  defaultChoice = randChoiceList $
    [ return AST_Import    <*> defaultO <*> defaultO              <*> no
    , return AST_Require   <*> defaultO                           <*> no
    , return AST_TopScript <*> defaultO                           <*> no
    , return AST_Event     <*> defaultO <*> defaultO <*> defaultO <*> no
    ]

instance Intermediate (TopLevelExpr o) (AST_TopLevel o) where
  toInterm   ast = case ast of
    AST_Require   a     loc -> [RequireExpr] <*> uc0 a           <*> [loc]
    AST_Import    a   b loc -> [ImportExpr ] <*> uc0 a  <*> ti b <*> [loc]
    AST_TopScript a     loc -> [TopScript  ] <*> ti  a           <*> [loc]
    AST_Event     a _ b loc -> [EventExpr  ] <*>    [a] <*> ti b <*> [loc]
    AST_TopComment     _loc -> mzero
  fromInterm obj = case obj of
    RequireExpr a   loc -> [AST_Require  ] <*> nc0 a                    <*> [loc]
    ImportExpr  a b loc -> [AST_Import   ] <*> nc0 a           <*> fi b <*> [loc]
    TopScript   a   loc -> [AST_TopScript] <*> fi  a                    <*> [loc]
    EventExpr   a b loc -> [AST_Event    ] <*>    [a] <*> [[]] <*> fi b <*> [loc]

isAST_Attribute :: AST_TopLevel o -> Bool
isAST_Attribute o = case o of { AST_Require{} -> True; AST_Import{} -> True; _ -> False; }

-- | Split a list of 'AST_TopLevel' items into a tripple, the "require" statements, the "import"
-- statements. This function scans the list lazily and returns as soon as an 'AST_TopLevel' item in
-- the list is found that is not one of 'AST_Require', 'AST_Import' or 'AST_TopComment'.
-- 
-- Notice that this function takes an 'AST_TopLevel' and returns a list of 'AttributeExpr's, not a
-- list of 'AST_Attribute's. This is because this function is designed for assisting in evaluation
-- of the import statements of a Dao script file, specifically in order to generate a dependency
-- graph.
getRequiresAndImports :: [AST_TopLevel o] -> ([AttributeExpr], [(AttributeExpr, NamespaceExpr)])
getRequiresAndImports = loop [] [] where
  loop requires imports ox = case ox of
    AST_Require a   _ : ox -> loop (requires ++ uc0 a) imports ox
    AST_Import  a b _ : ox -> loop requires (imports ++ (pure (,) <*> uc0 a <*> toInterm b)) ox
    AST_TopComment{}  : ox -> loop requires imports ox
    _                      -> (requires, imports)

instance NFData o => NFData (AST_TopLevel o) where
  rnf (AST_Require    a b    ) = deepseq a $! deepseq b ()
  rnf (AST_Import     a b c  ) = deepseq a $! deepseq b $! deepseq c ()
  rnf (AST_TopScript  a b    ) = deepseq a $! deepseq b ()
  rnf (AST_Event      a b c d) = deepseq a $! deepseq b $! deepseq c $! deepseq d ()
  rnf (AST_TopComment a      ) = deepseq a ()

instance HasNullValue (AST_TopLevel o) where
  nullValue = AST_TopScript nullValue LocationUnknown
  testNull (AST_TopScript a _) = testNull a
  testNull _ = False

instance HasLocation (AST_TopLevel o) where
  getLocation o = case o of
    AST_Require    _     o -> o
    AST_Import     _ _   o -> o
    AST_TopScript  _     o -> o
    AST_Event      _ _ _ o -> o
    AST_TopComment _       -> LocationUnknown
  setLocation o loc = case o of
    AST_Require    a      _ -> AST_Require    a       loc
    AST_Import     a b    _ -> AST_Import     a b     loc
    AST_TopScript  a      _ -> AST_TopScript  a       loc
    AST_Event      a b c  _ -> AST_Event      a b c   loc
    AST_TopComment a        -> AST_TopComment a
  delLocation o = case o of
    AST_Require    a      _ -> AST_Require    (delLocation a) LocationUnknown
    AST_Import     a b    _ -> AST_Import     (delLocation a) (delLocation b) LocationUnknown
    AST_TopScript  a      _ -> AST_TopScript  (delLocation a) LocationUnknown
    AST_Event      a b c  _ -> AST_Event      a b (delLocation c) LocationUnknown
    AST_TopComment a        -> AST_TopComment a  

instance PPrintable o => PPrintable (AST_TopLevel o) where
  pPrint o = case o of
    AST_Require   a      _ -> pWrapIndent [pString "require ", pPrint a, pString ";"]
    AST_Import    a b    _ -> pWrapIndent [pString "import  ", pPrint a, pPrint b, pString ";"]
    AST_TopScript a      _ -> pPrint a
    AST_Event     a b c  _ -> pClosure (pShow a >> mapM_ pPrint b) " { " " }" (map pPrint (getAST_CodeBlock c))
    AST_TopComment a       -> mapM_ (\a -> pPrint a >> pNewLine) a

----------------------------------------------------------------------------------------------------

-- | A program is just a list of 'TopLevelExpr's. It serves as the 'Intermediate'
-- representation of a 'AST_SourceCode'.
newtype Program o = Program { topLevelExprs :: [TopLevelExpr o] } deriving (Eq, Ord, Typeable)

instance Show o => Show (Program o) where { show (Program o) = unlines (map show o) }

instance HasNullValue (Program o) where
  nullValue = Program []
  testNull (Program p) = null p

instance HasLocation (Program o) where
  getLocation o = case topLevelExprs o of
    [] -> LocationUnknown
    [o] -> getLocation o
    o:ox -> mappend (getLocation o) (getLocation (foldl (flip const) o ox))
  setLocation o _ = o
  delLocation o = Program (fmap delLocation (topLevelExprs o))

----------------------------------------------------------------------------------------------------

-- | A 'SourceCode' is the structure loaded from source code. An 'ExecUnit' object is constructed from
-- 'SourceCode'.
data AST_SourceCode o
  = AST_SourceCode
    { sourceModified :: Int
    , sourceFullPath :: UStr
      -- ^ the URL (full file path) from where this source code was received.
    , directives     :: [AST_TopLevel o]
    }
  deriving (Eq, Ord, Typeable)

instance NFData o => NFData (AST_SourceCode o) where
  rnf (AST_SourceCode a b c) = deepseq a $! deepseq b $! deepseq c ()

instance HasNullValue (AST_SourceCode o) where
  nullValue = (AST_SourceCode 0 nil [])
  testNull (AST_SourceCode 0 a []) | a==nil = True
  testNull _ = False

instance PPrintable o => PPrintable (AST_SourceCode o) where
  pPrint sc = do
    let (attrs, dirs) = span isAST_Attribute (directives sc)
    mapM_ pPrint attrs
    pForceNewLine
    mapM_ (\dir -> pPrint dir >> pForceNewLine) dirs

instance Intermediate (Program o) (AST_SourceCode o) where
  toInterm   ast = [Program $ directives ast >>= toInterm]
  fromInterm obj = return $
    AST_SourceCode
    { sourceModified = 0
    , sourceFullPath = nil
    , directives     = topLevelExprs obj >>= fromInterm
    }