{-# 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 -> 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 String
"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
">>",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"then")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol () String
">>=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"bind")
  , (() -> String -> Name
forall l. l -> String -> Name l
Ident  () String
"return", () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"return")
  , (() -> String -> Name
forall l. l -> String -> Name l
Ident  () String
"force",  () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"force")
  , (() -> String -> Name
forall l. l -> String -> Name l
Ident  () String
"seq",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"seq")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"*",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"mult")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"+",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"add")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"-",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"sub")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"/",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"divi")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"==",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"eq")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"/=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"neq")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
">",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"gt")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"<",     () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"lt")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
">=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"gte")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"<=",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"lte")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"&&",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"and")
  , (() -> String -> Name
forall l. l -> String -> Name l
Symbol ()  String
"||",    () -> String -> QName
forall a. a -> String -> QName a
fayBuiltin () String
"or")
  ]

-- | Lookup a primop that was resolved to a Prelude definition.
findPrimOp :: N.QName -> Maybe N.QName
findPrimOp :: QName -> Maybe QName
findPrimOp (Qual ()
_ (ModuleName ()
_ String
"Prelude") 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 QName
_ = 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 ()
_ String
"Prelude") Name
_) -> QName -> Maybe QName
findPrimOp QName
q
  (UnQual ()
_ 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 () String
"Prelude") Name
n
  QName
_ -> Maybe QName
forall a. Maybe a
Nothing