Add CheckNativeParams pass

qsctr · Jul 25, 2020 · 46048b4 · 46048b4
1 parent 7b1fcbd
commit 46048b4
Show file tree

Hide file tree

Showing 4 changed files with 46 additions and 7 deletions.
diff --git a/src/Language/Dtfpl/Simplify.hs b/src/Language/Dtfpl/Simplify.hs
@@ -18,14 +18,15 @@ import           Language.Dtfpl.Simplify.GenIdentFull
 import           Language.Dtfpl.Step
 import           Language.Dtfpl.Syntax
 
-import           Language.Dtfpl.Simplify.AliasCase    ()
-import           Language.Dtfpl.Simplify.Curry        ()
-import           Language.Dtfpl.Simplify.InitGen      ()
+import           Language.Dtfpl.Simplify.AliasCase         ()
+import           Language.Dtfpl.Simplify.CheckNativeParams ()
+import           Language.Dtfpl.Simplify.Curry             ()
+import           Language.Dtfpl.Simplify.InitGen           ()
 import           Language.Dtfpl.Simplify.NameResolve
-import           Language.Dtfpl.Simplify.ParseNative  ()
-import           Language.Dtfpl.Simplify.Reorder      ()
-import           Language.Dtfpl.Simplify.UnDef        ()
-import           Language.Dtfpl.Simplify.UnLamMatch   ()
+import           Language.Dtfpl.Simplify.ParseNative       ()
+import           Language.Dtfpl.Simplify.Reorder           ()
+import           Language.Dtfpl.Simplify.UnDef             ()
+import           Language.Dtfpl.Simplify.UnLamMatch        ()
 
 -- | Simplify a complete module from ModResolved to Core.
 simplify :: Members '[Reader ModuleDeps, Reader Config, Error Err, NodeProc] r
@@ -36,6 +37,7 @@ simplify mod_ = runGenIdentFull $
     >>= step
     >>= step
     >>= step
+    >>= step
     >>= nameResolve
     >>= step
     >>= step
diff --git a/src/Language/Dtfpl/Simplify/CheckNativeParams.hs b/src/Language/Dtfpl/Simplify/CheckNativeParams.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Language.Dtfpl.Simplify.CheckNativeParams () where
+
+import           Data.Foldable
+import           Polysemy.Error
+
+import           Language.Dtfpl.Err
+import           Language.Dtfpl.Generate.Identifier
+import           Language.Dtfpl.Simplify.SimplifyErr
+import           Language.Dtfpl.Step
+import           Language.Dtfpl.Syntax
+
+type instance StepEffs 'CheckedNativeParams = '[Error Err]
+
+instance Step Decl 'CheckedNativeParams where
+    step def@(Def _ (T alts)) = do
+        for_ alts \(A (DefAlt (T pats) _) _) ->
+            for_ pats \pat -> case node pat of
+                VarPat ib@(IdentBind (A (Ident s) _))
+                    | identifierize s /= s ->
+                        throw $ SimplifyErr $ InvalidNativeArgErr ib
+                _ -> pure ()
+        autoStep def
+    step decl = autoStep decl
diff --git a/src/Language/Dtfpl/Simplify/SimplifyErr.hs b/src/Language/Dtfpl/Simplify/SimplifyErr.hs
@@ -28,6 +28,7 @@ data SimplifyErr
     = ParseNativeErr
         String -- ^ Error message
         SourcePos -- ^ Error position
+    | InvalidNativeArgErr (IdentBind (Pred 'CheckedNativeParams))
     -- | An identifier being defined with the same name as an already existing
     -- one.
     | DuplicateIdentErr
@@ -54,6 +55,10 @@ instance ErrMessage SimplifyErr where
         [ "Error while parsing native code"
         , format pos
         , msg ]
+    errMessage (InvalidNativeArgErr ident) =
+        [ "Invalid native function parameter name " ++ formatQuote ident
+        , "Native function parameter names must be valid ECMAScript identifiers"
+        , "  and must not contain `$` or `_`" ]
     errMessage (DuplicateIdentErr new old) =
         ("Duplicate identifier " ++ formatQuote new)
         : duplicateIdentMessage old
@@ -80,6 +85,7 @@ instance ErrMessage SimplifyErr where
 
 instance ErrLoc SimplifyErr where
     errLoc (ParseNativeErr _ _)          = Nothing
+    errLoc (InvalidNativeArgErr ib)      = Just $ ann $ unIdentBind ib
     errLoc (DuplicateIdentErr new _)     = ann new
     errLoc (UnresolvedIdentErr ident)    = ann ident
     errLoc (AmbiguousIdentErr ident _ _) = ann ident

diff --git a/src/Language/Dtfpl/Syntax.hs b/src/Language/Dtfpl/Syntax.hs
@@ -79,6 +79,7 @@ $(promote [d|
         = Source
         | ModResolved
         | ParsedNative
+        | CheckedNativeParams
         | InitGen
         | NoDef
         | NoLamMatch