{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

--------------------------------------------------------------------------------
-- | Primitive Operations
-- Built-in operations that aren't actually compiled from
-- anywhere, they come from runtime.js.
--
-- They're in the names list so that they can be overriden by the user
-- in e.g. let a * b = a - b in 1 * 2.
--
-- So we resolve them to Fay$, i.e. the prefix used for the runtime
-- support. $ is not allowed in Haskell module names, so there will be
-- no conflicts if a user decicdes to use a module named Fay.
--
-- So e.g. will compile to (*) Fay$$mult, which is in runtime.js.

module Fay.Compiler.PrimOp
  ( fayBuiltin
  , findPrimOp
  , resolvePrimOp
  ) where

import           Fay.Compiler.Prelude

import           Fay.Exts.NoAnnotation           (unAnn)
import qualified Fay.Exts.NoAnnotation           as N

import           Data.Map                        (Map)
import qualified Data.Map                        as M
import           Language.Haskell.Exts

-- | Make an identifier from the built-in HJ module.
fayBuiltin :: a -> String -> QName a
fayBuiltin :: a -> String -> QName a
fayBuiltin a :: a
a = a -> ModuleName a -> Name a -> QName a
forall l. l -> ModuleName l -> Name l -> QName l
Qual a
a (a -> String -> ModuleName a
forall l. l -> String -> ModuleName l
ModuleName a
a "Fay$") (Name a -> QName a) -> (String -> Name a) -> String -> QName a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> Name a
forall l. l -> String -> Name l
Ident a
a

-- | Mapping from unqualified names to qualified primitive names.
primOpsMap :: Map N.Name N.QName
primOpsMap :: Map Name QName
primOpsMap = [(Name, QName)] -> Map Name QName
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (() -> String -> Name
forall l. l -> String -> Name l
Symbol () ">>",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "then")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol () ">>=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "bind")
  , (() -> String -> Name
forall l. l -> String -> Name l
Ident  () "return", () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "return")
  , (() -> String -> Name
forall l. l -> String -> Name l
Ident  () "force",  () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "force")
  , (() -> String -> Name
forall l. l -> String -> Name l
Ident  () "seq",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "seq")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "*",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "mult")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "+",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "add")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "-",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "sub")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "/",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "divi")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "==",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "eq")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "/=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "neq")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  ">",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "gt")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "<",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "lt")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  ">=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "gte")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "<=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "lte")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "&&",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "and")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  "||",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () "or")
  ]

-- | Lookup a primop that was resolved to a Prelude definition.
findPrimOp :: N.QName -> Maybe N.QName
findPrimOp :: QName -> Maybe QName
findPrimOp (Qual _ (ModuleName _ "Prelude") s :: Name
s) = Name -> Map Name QName -> Maybe QName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
s Map Name QName
primOpsMap
findPrimOp _ = Maybe QName
forall a. Maybe a
Nothing

-- | If this is resolved to a Prelude identifier or if it's unqualified,
-- check if it's a primop
resolvePrimOp :: QName a -> Maybe N.QName
resolvePrimOp :: QName a -> Maybe QName
resolvePrimOp (QName a -> QName
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> QName
q) = case QName
q of
  (Qual _ (ModuleName _ "Prelude") _) -> QName -> Maybe QName
findPrimOp QName
q
  (UnQual _ n :: Name
n) -> QName -> Maybe QName
findPrimOp (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ () -> ModuleName () -> Name -> QName
forall l. l -> ModuleName l -> Name l -> QName l
Qual () (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () "Prelude") Name
n
  _ -> Maybe QName
forall a. Maybe a
Nothing