Skip to content
This repository
Browse code

Remove unnecessary QNames at this stage.

  • Loading branch information...
commit ca76b99fcfdcf76f73459df9027a56f72e2cc398 1 parent 4c2de35
Chris Done authored October 28, 2012
10  src/Data/List/Extra.hs
... ...
@@ -0,0 +1,10 @@
  1
+module Data.List.Extra where
  2
+
  3
+import Data.List hiding (map)
  4
+import Prelude hiding (map)
  5
+
  6
+unionOf :: (Eq a) => [[a]] -> [a]
  7
+unionOf = foldr union []
  8
+
  9
+for :: (Functor f) => f a -> (a -> b) -> f b
  10
+for = flip fmap
106  src/Language/Fay/Compiler.hs
@@ -22,26 +22,24 @@ module Language.Fay.Compiler
22 22
   ,compileToplevelModule)
23 23
   where
24 24
 
25  
-import           Language.Fay.Compiler.FFI
26  
-import           Language.Fay.Compiler.Misc
27  
-import           Language.Fay.Print         (printJSString)
28  
-import           Language.Fay.Types
29  
-
30  
-import           Control.Applicative
31  
-import           Control.Arrow
32  
-import           Control.Monad.Error
33  
-import           Control.Monad.IO
34  
-import           Control.Monad.State
35  
-import           Data.Default               (def)
36  
-import           Data.List
37  
-import           Data.Maybe
38  
-import           Data.Word
39  
-import           Language.Haskell.Exts
40  
-import           System.Directory           (doesFileExist)
41  
-import           System.FilePath            ((</>))
42  
-import           System.IO
43  
-import           System.Process.Extra
44  
-import           System.Random
  25
+import Language.Fay.Compiler.FFI
  26
+import Language.Fay.Compiler.Misc
  27
+import Language.Fay.Print         (printJSString)
  28
+import Language.Fay.Types
  29
+
  30
+import Control.Applicative
  31
+import Control.Monad.Error
  32
+import Control.Monad.IO
  33
+import Control.Monad.State
  34
+import Data.Default               (def)
  35
+import Data.List
  36
+import Data.List.Extra
  37
+import Data.Maybe
  38
+import Language.Haskell.Exts
  39
+import System.Directory           (doesFileExist)
  40
+import System.FilePath            ((</>))
  41
+import System.IO
  42
+import System.Process.Extra
45 43
 
46 44
 --------------------------------------------------------------------------------
47 45
 -- Top level entry points
@@ -182,17 +180,18 @@ initialPass_dataDecl _ _decl constructors =
182 180
   forM_ constructors $ \(QualConDecl _ _ _ condecl) ->
183 181
     case condecl of
184 182
       ConDecl name types -> do
185  
-        let fields =  map (UnQual . Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types
186  
-        addRecordState (UnQual name) fields
  183
+        let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types
  184
+        addRecordState name fields
187 185
       InfixConDecl _t1 name _t2 ->
188  
-        addRecordState (UnQual name) ["slot1", "slot2"]
  186
+        addRecordState name ["slot1", "slot2"]
189 187
       RecDecl name fields' -> do
190 188
         let fields = concatMap fst fields'
191  
-        addRecordState (UnQual name) (map UnQual fields)
  189
+        addRecordState name fields
192 190
 
193 191
   where
194  
-    addRecordState :: QName -> [QName] -> Compile ()
195  
-    addRecordState name fields = modify $ \s -> s { stateRecords = (name,fields) : stateRecords s }
  192
+    addRecordState :: Name -> [Name] -> Compile ()
  193
+    addRecordState name fields = modify $ \s -> s
  194
+      { stateRecords = (UnQual name,map UnQual fields) : stateRecords s }
196 195
 
197 196
 --------------------------------------------------------------------------------
198 197
 -- Typechecking
@@ -320,7 +319,7 @@ compilePatBind toplevel sig pat =
320 319
     PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->
321 320
       case ffiExp rhs of
322 321
         Just formatstr -> case sig of
323  
-          Just sig -> compileFFI srcloc (UnQual ident) formatstr sig
  322
+          Just sig -> compileFFI srcloc ident formatstr sig
324 323
           Nothing  -> throwError (FfiNeedsTypeSig pat)
325 324
         _ -> compileUnguardedRhs srcloc toplevel ident rhs
326 325
     PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls ->
@@ -334,7 +333,7 @@ compilePatBind toplevel sig pat =
334 333
 compileUnguardedRhs :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt]
335 334
 compileUnguardedRhs srcloc toplevel ident rhs = do
336 335
   body <- compileExp rhs
337  
-  bind <- bindToplevel srcloc toplevel (UnQual ident) (thunk body)
  336
+  bind <- bindToplevel srcloc toplevel ident (thunk body)
338 337
   return [bind]
339 338
 
340 339
 convertGADT :: GadtDecl -> QualConDecl
@@ -356,53 +355,50 @@ compileDataDecl toplevel _decl constructors =
356 355
     forM constructors $ \(QualConDecl srcloc _ _ condecl) ->
357 356
       case condecl of
358 357
         ConDecl name types  -> do
359  
-          let fields =  map (UnQual . Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types
  358
+          let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types
360 359
               fields' = (zip (map return fields) types)
361  
-          cons <- makeConstructor (UnQual name) fields
  360
+          cons <- makeConstructor name fields
362 361
           func <- makeFunc name fields
363  
-          emitFayToJs (UnQual name) fields'
364  
-          emitJsToFay (UnQual name) fields'
  362
+          emitFayToJs name fields'
  363
+          emitJsToFay name fields'
365 364
           return [cons, func]
366 365
         InfixConDecl t1 name t2 -> do
367 366
           let slots = ["slot1","slot2"]
368 367
               fields = zip (map return slots) [t1, t2]
369  
-          cons <- makeConstructor (UnQual name) slots
  368
+          cons <- makeConstructor name slots
370 369
           func <- makeFunc name slots
371  
-          emitFayToJs (UnQual name) fields
372  
-          emitJsToFay (UnQual name) fields
  370
+          emitFayToJs name fields
  371
+          emitJsToFay name fields
373 372
           return [cons, func]
374 373
         RecDecl name fields' -> do
375  
-          let fields = map UnQual (concatMap fst fields')
376  
-          cons <- makeConstructor (UnQual name) fields
  374
+          let fields = concatMap fst fields'
  375
+          cons <- makeConstructor name fields
377 376
           func <- makeFunc name fields
378 377
           funs <- makeAccessors srcloc fields
379  
-          emitFayToJs (UnQual name) (map (first (map UnQual )) fields')
380  
-          emitJsToFay (UnQual name) (map (first (map UnQual )) fields')
  378
+          emitFayToJs name fields'
  379
+          emitJsToFay name fields'
381 380
           return (cons : func : funs)
382 381
 
383 382
   where
384 383
     -- Creates a constructor R_RecConstr for a Record
385  
-    makeConstructor name fields = do
386  
-          let fieldParams = map JsNameVar fields
387  
-          return $
388  
-            JsVar (JsConstructor name) $
389  
-              JsFun fieldParams
390  
-                  (flip map fields $ \field ->
391  
-                     JsSetProp JsThis (JsNameVar field) (JsName (JsNameVar field)))
392  
-                Nothing
  384
+    makeConstructor :: Name -> [Name] -> Compile JsStmt
  385
+    makeConstructor name (map (JsNameVar . UnQual) -> fields) = do
  386
+      return $
  387
+        JsVar (JsConstructor (UnQual name)) $
  388
+          JsFun fields (for fields $ \field -> JsSetProp JsThis field (JsName field))
  389
+            Nothing
393 390
 
394 391
     -- Creates a function to initialize the record by regular application
395  
-    makeFunc :: Name -> [QName] -> Compile JsStmt
396  
-    makeFunc name fields = do
397  
-          let fieldParams = map JsNameVar fields
398  
-          let fieldExps = map (JsName . JsNameVar) fields
  392
+    makeFunc :: Name -> [Name] -> Compile JsStmt
  393
+    makeFunc name (map (JsNameVar . UnQual) -> fields) = do
  394
+          let fieldExps = map JsName fields
399 395
           return $ JsVar (JsNameVar (UnQual name)) $
400 396
             foldr (\slot inner -> JsFun [slot] [] (Just inner))
401 397
               (thunk $ JsNew (JsConstructor (UnQual name)) fieldExps)
402  
-              fieldParams
  398
+              fields
403 399
 
404 400
     -- Creates getters for a RecDecl's values
405  
-    makeAccessors :: SrcLoc -> [QName] -> Compile [JsStmt]
  401
+    makeAccessors :: SrcLoc -> [Name] -> Compile [JsStmt]
406 402
     makeAccessors srcloc fields =
407 403
       forM fields $ \name ->
408 404
            bindToplevel srcloc
@@ -411,7 +407,7 @@ compileDataDecl toplevel _decl constructors =
411 407
                         (JsFun [JsNameVar "x"]
412 408
                                []
413 409
                                (Just (thunk (JsGetProp (force (JsName (JsNameVar "x")))
414  
-                                                       (JsNameVar name)))))
  410
+                                                       (JsNameVar (UnQual name))))))
415 411
 
416 412
 -- | Compile a function which pattern matches (causing a case analysis).
417 413
 compileFunCase :: Bool -> [Match] -> Compile [JsStmt]
@@ -420,7 +416,7 @@ compileFunCase toplevel matches@(Match srcloc name argslen _ _ _:_) = do
420 416
   pats <- fmap optimizePatConditions (mapM compileCase matches)
421 417
   bind <- bindToplevel srcloc
422 418
                        toplevel
423  
-                       (UnQual name)
  419
+                       name
424 420
                        (foldr (\arg inner -> JsFun [arg] [] (Just inner))
425 421
                               (stmtsThunk (concat pats ++ basecase))
426 422
                               args)
16  src/Language/Fay/Compiler/FFI.hs
@@ -30,7 +30,7 @@ import           Safe
30 30
 
31 31
 -- | Compile an FFI call.
32 32
 compileFFI :: SrcLoc -- ^ Location of the original FFI decl.
33  
-           -> QName  -- ^ Name of the to-be binding.
  33
+           -> Name  -- ^ Name of the to-be binding.
34 34
            -> String -- ^ The format string.
35 35
            -> Type   -- ^ Type signature.
36 36
            -> Compile [JsStmt]
@@ -53,23 +53,23 @@ compileFFI srcloc name formatstr sig = do
53 53
         returnType = last funcFundamentalTypes
54 54
 
55 55
 -- Make a Fay→JS encoder.
56  
-emitFayToJs :: QName -> [([QName], BangType)] -> Compile ()
  56
+emitFayToJs :: Name -> [([Name],BangType)] -> Compile ()
57 57
 emitFayToJs name (explodeFields -> fieldTypes) =
58 58
   modify $ \s -> s { stateFayToJs = translator : stateFayToJs s }
59 59
 
60 60
   where
61  
-    translator = JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor name))
  61
+    translator = JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor (UnQual name)))
62 62
                       [JsEarlyReturn (JsObj (("instance",JsLit (JsStr (printJSString name)))
63 63
                                              : zipWith declField [0..] fieldTypes))]
64 64
                       []
65 65
     -- Declare/encode Fay→JS field
66  
-    declField :: Int -> (QName,BangType) -> (String,JsExp)
  66
+    declField :: Int -> (Name,BangType) -> (String,JsExp)
67 67
     declField _i (fname,typ) =
68 68
       (prettyPrint fname
69 69
       ,fayToJs (case argType (bangType typ) of
70 70
                  known -> typeRep known)
71 71
                (force (JsGetProp (JsName transcodingObjForced)
72  
-                                 (JsNameVar fname))))
  72
+                                 (JsNameVar (UnQual fname)))))
73 73
 
74 74
 transcodingObj :: JsName
75 75
 transcodingObj = JsNameVar "obj"
@@ -223,7 +223,7 @@ jsToFayDispatcher cases =
223 223
           JsEarlyReturn (JsName transcodingObj)
224 224
 
225 225
 -- Make a JS→Fay decoder
226  
-emitJsToFay ::  QName -> [([QName], BangType)] -> Compile ()
  226
+emitJsToFay ::  Name -> [([Name], BangType)] -> Compile ()
227 227
 emitJsToFay name (explodeFields -> fieldTypes) =
228 228
   modify $ \s -> s { stateJsToFay = translator : stateJsToFay s }
229 229
 
@@ -231,11 +231,11 @@ emitJsToFay name (explodeFields -> fieldTypes) =
231 231
     translator =
232 232
       JsIf (JsEq (JsGetPropExtern (JsName transcodingObj) "instance")
233 233
                  (JsLit (JsStr (printJSString name))))
234  
-           [JsEarlyReturn (JsNew (JsConstructor name)
  234
+           [JsEarlyReturn (JsNew (JsConstructor (UnQual name))
235 235
                                  (map decodeField fieldTypes))]
236 236
            []
237 237
     -- Decode JS→Fay field
238  
-    decodeField :: (QName,BangType) -> JsExp
  238
+    decodeField :: (Name,BangType) -> JsExp
239 239
     decodeField (fname,typ) =
240 240
       jsToFay (argType (bangType typ))
241 241
               (JsGetPropExtern (JsName transcodingObj)
12  src/Language/Fay/Compiler/Misc.hs
@@ -46,12 +46,18 @@ stmtsThunk stmts = JsNew JsThunk [JsFun [] stmts Nothing]
46 46
 uniqueNames :: [JsName]
47 47
 uniqueNames = map JsParam [1::Integer ..]
48 48
 
  49
+-- | Qualify a name for the current module.
  50
+qualify :: Name -> Compile QName
  51
+qualify name = do
  52
+  modulename <- gets stateModuleName
  53
+  return (Qual modulename name)
  54
+
49 55
 -- | Make a top-level binding.
50  
-bindToplevel :: SrcLoc -> Bool -> QName -> JsExp -> Compile JsStmt
  56
+bindToplevel :: SrcLoc -> Bool -> Name -> JsExp -> Compile JsStmt
51 57
 bindToplevel srcloc toplevel name expr = do
52 58
   exportAll <- gets stateExportAll
53  
-  when (toplevel && exportAll) $ emitExport (EVar name)
54  
-  return (JsMappedVar srcloc (JsNameVar name) expr)
  59
+  when (toplevel && exportAll) $ emitExport (EVar (UnQual name))
  60
+  return (JsMappedVar srcloc (JsNameVar (UnQual name)) expr)
55 61
 
56 62
 -- | Emit exported names.
57 63
 emitExport :: ExportSpec -> Compile ()

0 notes on commit ca76b99

Please sign in to comment.
Something went wrong with that request. Please try again.