{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Language.Del.AST where
import qualified Data.Text as T
import qualified Data.Map.Strict as Map
import           Language.Del.TypeTable
import           Network.HTTP.Req

data DelNum
    = DelInt Integer
    | DelFloat Double
    deriving (Show, Eq)

type Name = T.Text

data Expr
    = Add [Expr]
    | Mul [Expr]
    | Sub Expr Expr
    | Div Expr Expr
    | Pow Expr Expr
    | Lt Expr Expr
    | Gt Expr Expr
    | LtE Expr Expr
    | GtE Expr Expr
    | Negate Expr
    | Subscript Expr T.Text
    | Apply Expr [Expr]
    | NativeCall T.Text [Expr]
    | Id Name
    | ScopedId Name Name
    | Number DelNum
    | Boolean Bool
    | Let Name Expr Expr
    | If Expr Expr Expr
    deriving Eq

rootKey :: T.Text
rootKey = "root"

data SourceUrl = HttpSource (Url 'Http)
               | HttpsSource (Url 'Https)
               deriving Eq
type Source = Either Name SourceUrl

data Def = Def T.Text Type [(T.Text, Type)] Expr deriving Eq
data Import = Import Source T.Text

instance Show Def where
    show (Def n ret args body) = concat [
        "(", T.unpack n, ":", (show ret), " ",
        unwords $ map (\(a, t) -> T.unpack a ++ ":" ++ show t) args,
        ") -> ", show body]

instance Show Import where
    show (Import (Left name) alias) = concat [
        "(#import ", T.unpack name, " -> ", T.unpack alias, ")"]
    show (Import (Right url) alias) = concat [
        "(#import ", show url, " -> ", T.unpack alias, ")"]

-- Programs are maps from bound name to the form that binds it
data AST = AST (Map.Map T.Text Def) [Import]

instance Show AST where
    show (AST m i) = imps ++ "\n" ++ defs
        where defs = unlines . map (show . snd) . Map.toAscList $ m
              imps = unlines $ map show i

getAstMap :: AST -> Map.Map T.Text Def
getAstMap (AST m _) = m

makeIndent :: Integer -> String
makeIndent 0 = ""
makeIndent n = "  " ++ makeIndent (n - 1)

showExprList :: String -> [Expr] -> String
showExprList h xs = concat ["(", h, " ", unwords $ map show xs, ")"]

instance Show Expr where
    show (Add xs) = showExprList "+" xs
    show (Mul xs) = showExprList "*" xs
    show (Sub x1 x2) = showExprList "-" [x1, x2]
    show (Div x1 x2) = showExprList "/" [x1, x2]
    show (Pow x1 x2) = showExprList "^" [x1, x2]
    show (Gt x1 x2) = showExprList ">" [x1, x2]
    show (Lt x1 x2) = showExprList "<" [x1, x2]
    show (GtE x1 x2) = showExprList ">=" [x1, x2]
    show (LtE x1 x2) = showExprList "<=" [x1, x2]
    show (Negate x) = "~" ++ show x
    show (Subscript e sub) = show e ++ "_" ++ T.unpack sub
    show (Apply h xs) = showExprList (show h) xs
    show (Id n) = T.unpack n
    show (ScopedId p n) = T.unpack p ++ "." ++ T.unpack n
    show (Number (DelInt i)) = show i
    show (Number (DelFloat f)) = show f
    show (Let n e b) = concat ["(let (", T.unpack n, " ", show e, ") ", show b]
    show (Boolean b) = show b
    show (If c t f) = concat ["(if ", show c, " ", show t, " ", show f]
    show (NativeCall n xs) = showExprList ("$" ++ T.unpack n) xs

instance Show SourceUrl where
    show (HttpSource u) = show u
    show (HttpsSource u) = show u

canonicalId :: Expr -> Expr
canonicalId (ScopedId p n) = Id $ T.concat [p, ".", n]
canonicalId e@(Id _) = e
canonicalId _ = undefined

-- Converts a list of Del numbers to floats if any elements in the list are
-- floats; otherwise, keeps them as integers
promote :: [DelNum] -> [DelNum]
promote ns = if anyFloats ns then map toFloat ns else ns

toFloat :: DelNum -> DelNum
toFloat (DelInt i) = DelFloat . fromIntegral $ i
toFloat float = float

anyFloats :: [DelNum] -> Bool
anyFloats ((DelFloat _):_) = True
anyFloats (_:xs) = anyFloats xs
anyFloats [] = False

sumFloats :: DelNum -> DelNum -> DelNum
sumFloats (DelFloat f1) (DelFloat f2) = DelFloat $ f1 + f2
sumFloats _ _ = undefined

sumInts :: DelNum -> DelNum -> DelNum
sumInts (DelInt f1) (DelInt f2) = DelInt $ f1 + f2
sumInts _ _ = undefined

prodFloats :: DelNum -> DelNum -> DelNum
prodFloats (DelFloat f1) (DelFloat f2) = DelFloat $ f1 * f2
prodFloats _ _ = undefined

prodInts :: DelNum -> DelNum -> DelNum
prodInts (DelInt f1) (DelInt f2) = DelInt $ f1 * f2
prodInts _ _ = undefined

wrapUnary :: (forall n. Num n => n -> n) -> DelNum -> DelNum
wrapUnary func (DelInt i) = DelInt $ func i
wrapUnary func (DelFloat f) = DelFloat $ func f

getFloat :: DelNum -> Double
getFloat (DelFloat f) = f
getFloat (DelInt i) = fromIntegral i

instance Num DelNum where
    a + b = if anyFloats [a, b]
               then sumFloats (toFloat a) (toFloat b)
               else sumInts a b
    a * b = if anyFloats [a, b]
               then prodFloats (toFloat a) (toFloat b)
               else prodInts a b
    abs = wrapUnary abs
    signum = wrapUnary signum
    negate = wrapUnary negate
    fromInteger = DelInt

instance Fractional DelNum where
    a / b = DelFloat $ getFloat a / getFloat b
    fromRational = DelFloat . fromRational

pow :: DelNum -> DelNum -> DelNum
pow (DelInt b) (DelInt p) = DelInt $ b ^ p
pow (DelFloat b) (DelInt p) = DelFloat $ b ^ p
pow (DelInt b) (DelFloat p) = DelFloat $ (fromInteger b) ** p
pow (DelFloat b) (DelFloat p) = DelFloat $ b ** p