{-# LANGUAGE MultiParamTypeClasses
          ,  FlexibleInstances #-}
module Core.Lower where

import qualified Frontend.AST as A
import qualified Core.Core as C
import Data.Monoid ((<>))
import Data.List (intercalate, groupBy, nubBy)
import Frontend.AST.Simplify

lowerLiteral A.LUnit = C.LUnit
lowerLiteral A.LTrue = C.LTrue
lowerLiteral A.LFalse = C.LFalse
lowerLiteral (A.LString s) = C.LString s
lowerLiteral (A.LInt i) = C.LNumber $ fromIntegral i
lowerLiteral (A.LDouble i) = C.LNumber i

lowerMatch A.Wildcard = C.Wildcard
lowerMatch (A.Bound n m) = C.Bound n $ lowerMatch m
lowerMatch (A.Tuple xs)
  = C.PList $ [C.PLit (C.LString "'Tuple'"), C.PLit $ C.LNumber $ fromIntegral $ length xs] ++ map lowerMatch xs
lowerMatch (A.List xs) = C.PList $ map lowerMatch xs
lowerMatch (A.Cons x y) = C.Cons (lowerMatch x) (lowerMatch y)
lowerMatch (A.Constructor n xs) = C.Constructor n (length xs) $ map lowerMatch xs
lowerMatch (A.Irrefutable n) = lowerMatch n
lowerMatch (A.Literal (A.LInt x))
  = C.Constructor "Integer" 1
                [ C.PLit $ C.LNumber $ fromIntegral x ]

lowerMatch (A.Literal (A.LDouble x))
  = C.Constructor "Integer" 1
                [ C.PLit $ C.LNumber x ]

lowerMatch (A.Literal (A.LString x))
  = C.Constructor "String" 1
                [ C.PLit $ C.LString x]
lowerMatch (A.Literal x)
  = C.PLit $ lowerLiteral x
lowerMatch (A.Unboxed x)
  = C.PLit $ lowerLiteral x

lowerMatch (A.Capture x) = C.Capture x


patternName :: C.Pat -> String
patternName C.Wildcard = "_"
patternName (C.Bound n p) = n <> patternName p
patternName (C.PLit l) = "_L"
patternName (C.Capture x) = x

lowerExpression (A.ELambda pat bod)
  = C.Lambda pat' bod'
    where pat' = lowerMatch pat
          bod' = lowerExpression bod
lowerExpression (A.EVar x) = C.Var x
lowerExpression (A.EQualifiedVar x) = C.Var $ intercalate "." x
lowerExpression (A.ETuple xs)
  = C.List $ [C.Literal $ C.LString "'Tuple'", C.Literal $ C.LNumber $ fromIntegral $ length xs] ++ map lowerExpression xs
lowerExpression (A.EList xs) = C.List $ map lowerExpression xs
lowerExpression (A.EIf x y z) = C.If (lowerExpression x) (lowerExpression y) (lowerExpression z)
lowerExpression (A.EApply x y) = C.Apply (lowerExpression x) (lowerExpression y)
lowerExpression (A.ECase arm e) = C.Case (map lowerCaseArm arm) $ lowerExpression e
lowerExpression (A.ELiteral x) = C.Literal (lowerLiteral x)
lowerExpression (A.EBinOp o x y) = C.BinOp (lowerExpression o) (lowerExpression x) (lowerExpression y)
lowerExpression (A.ELet bind bod) = makeLet bind bod
lowerExpression (A.EUnbox x) = C.Unbox $ lowerLiteral x

lowerCaseArm (x, y) = C.CaseArm (lowerMatch x) (lowerExpression y)

makeLet :: [(A.Match, A.Expression)] -> A.Expression -> C.Expression
makeLet [(x, y)] b = C.Let x' y' b'
  where (x', y', b') = (lowerMatch x, lowerExpression y, lowerExpression b)

makeLet ((x, y):xs) b = C.Let x' y' $ makeLet xs b
  where (x', y') = (lowerMatch x, lowerExpression y)

lower :: A.Program -> C.Program
lower = concatMap lowerDeclaration . simplify . nubBy dup where
  dup (A.Decl n m e) (A.Decl n' m' e')
    = n' == n && m == m'
  dup (A.Import ns) (A.Import ns') = ns == ns'
  dup _ _ = False

lowerDeclaration :: A.ToplevelStatement -> [C.Toplevel]
lowerDeclaration (A.Decl nm _ e) 
  = [C.Declare nm le]
    where le = lowerExpression e

lowerDeclaration (A.Import ns)
  = [C.Declare "_" (C.Apply (C.Var "rts.import") (C.Literal $ C.LString $ '"':ns ++ "\""))]

lowerDeclaration e@A.TypeDecl{} = lower $ transformTD e
lowerDeclaration _              = []
