packages feed

ycextra (empty) → 0.1

raw patch · 14 files changed

+830/−0 lines, 14 filesdep +basedep +containersdep +csvsetup-changed

Dependencies added: base, containers, csv, mtl, uniplate, yhccore

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dmitry Golubovsky 2008.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Dmitry Golubovsky nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks simpleUserHooks
+ Yhc/Core/AnnotatePrims.hs view
@@ -0,0 +1,93 @@+-- Annotation of normal primitives++module Yhc.Core.AnnotatePrims (+  buildPrimSpecMap+ ,normPrimSpecMap+ ,CoreStrictness (..)+ ,CoreTypeSig (..)+ ,buildPrimAnno+ ,buildNormPrimAnno+ ) where++import Data.Maybe+import Yhc.Core+import Yhc.Core.PrimAnnoRaw+import Yhc.Core.Annotation+import qualified Data.Map as M++-- Annotation key for functions and primitives++fparity (p@CorePrim {}) = corePrimArity p+fparity (f@CoreFunc {}) = length $ coreFuncArgs f++instance CoreAnnotable CoreFunc where+  toAnnotationKey (p@CorePrim {}) = "primitive_" ++ +                                    coreFuncName p ++ "/" ++ +                                    show (corePrimArity p)++  toAnnotationKey (f@CoreFunc {}) = "function_" +++                                    coreFuncName f ++ "/" +++                                    show (length $ coreFuncArgs f)++-- |Build a map of primitive specifications given the list of+-- primitive description records. This as well may be used by frontends.++buildPrimSpecMap :: [[String]] -> M.Map String [String]++buildPrimSpecMap pspc = M.fromList $ map bpsm pspc where+  bpsm (h:t) = (h, t)++-- |Specifications map of normal primitives++normPrimSpecMap :: M.Map String [String]++normPrimSpecMap = buildPrimSpecMap rawPrimAnno++-- Core function/primitive strictness is a list of Bools. True+-- at certain position means that a function or a primitive is strict+-- on the corresponding argument.++newtype CoreStrictness = CoreStrictness [Bool]++instance CoreProperty CoreStrictness where+  toAnnString (CoreStrictness bsct) = map (\b -> if b then 'T' else 'F') bsct+  fromAnnString s = mapM (\c -> case c of+                     'F' -> return False+                     'T' -> return True+                     _   -> fail $ "invalid strictness annotation: " ++ s) s+                >>= return . CoreStrictness++-- Core function/primitive type signature is a string containing Haskell+-- type expression.++newtype CoreTypeSig = CoreTypeSig String++instance CoreProperty CoreTypeSig where+  toAnnString (CoreTypeSig s) = s+  fromAnnString = return . CoreTypeSig++-- |Given the linked Core, build annotations for all primitives defined+-- that belong to the given set of primitives, that is, their names+-- are member keys of the given primitives specification map.++buildPrimAnno :: M.Map String [String] -> Core -> CoreAnnotations++buildPrimAnno mps core = ba M.empty (coreFuncs core) mps where+  ba am [] _ = am+  ba am (p:ps) mps | coreFuncName p `M.member` mps = +    ba am'' ps mps where+      bsct art "All" = replicate art True+      bsct art "None" = replicate art False+      bsct art s = take art $ map ('T' ==) s ++ repeat False+      (use:descr:impl:arity:strct:tsig:_) = fromJust $ M.lookup (coreFuncName p) mps+      am'  = addAnnotation p ("Strictness", CoreStrictness (bsct (read arity) strct)) am+      am'' = addAnnotation p ("Type", CoreTypeSig tsig) am'+  ba am (_:ps) mps = ba am ps mps++-- |Given the linked Core, build annotations for all normal primitives+-- that is, belonging to the 'normPrimSpecMap'.++buildNormPrimAnno :: Core -> CoreAnnotations++buildNormPrimAnno = buildPrimAnno normPrimSpecMap+
+ Yhc/Core/Annotation.hs view
@@ -0,0 +1,84 @@+-- Annotation framework for Yhc Core++module Yhc.Core.Annotation (+  CoreAnnotations,+  CoreAnnotable (..),+  CoreProperty (..),+  addAnnotation,+  getAnnotation,+  combineAnnotations) where++import Data.Maybe+import qualified Data.Map as M+import qualified Data.List as L+import Yhc.Core++-- |Annotations database: a two-level map to hold property mappings +-- for each of annotated objects.++type CoreAnnotations = M.Map String (M.Map String String)++-- |For each annotable object, unique key should be generated, to be used+-- with the top level map in the annotations database.++class CoreAnnotable a where+  toAnnotationKey :: a -> String++-- |For each property, an encoding (to String) and decoding (from String)+-- functions should be defined.++class CoreProperty p where+  toAnnString :: p -> String    -- ^arbitrary property to a string to store+  fromAnnString :: (Monad m) => String -> m p -- ^from stored string to property value or fail++-- |Given an annotable object, append a property with given name and value+-- to the existing annotations database.++addAnnotation :: (CoreAnnotable a, CoreProperty p) +              => a -- ^annotable object+              -> (String, p) -- ^pair of name and value+              -> CoreAnnotations -- ^existing annotations database+              -> CoreAnnotations -- ^updated annotations database++addAnnotation a (n, p) b =+  let ak = toAnnotationKey a                   -- annotation key to lookup at top level+      aa = M.findWithDefault M.empty ak b      -- second level map or empty map if new+      ps = toAnnString p                       -- stringify the property value+      aa' = M.insert n ps aa                   -- insert/replace property at the second level+  in  M.insert ak aa' b                        -- insert/replace properties at the top level+  ++getAnnotation :: (CoreAnnotable a, CoreProperty p) +              => a -- ^annotable object+              -> String -- ^property name+              -> CoreAnnotations -- ^annotations database+              -> Maybe p -- ^returned value or nothing++getAnnotation a n b = do                       -- as we are in a monad...+  let ak = toAnnotationKey a                   -- annotation key to lookup at top level+  aa <- M.lookup ak b                          -- second level map or fail right here+  ps <- M.lookup n aa                          -- property value or fail right here+  p <- fromAnnString ps                        -- decode property value or fail rught here+  return p+++-- |Given the two annotation sets, combine them into one. If the same object +-- is annotated in both sets, annotations are combines for such object, +-- and left annotations take precedence.++combineAnnotations :: CoreAnnotations -> CoreAnnotations -> CoreAnnotations++combineAnnotations l r = +  let flkup = flip M.lookup+      lkeys = M.keys l+      rkeys = M.keys r+      ikeys = L.intersect lkeys rkeys+      lnodup = lkeys L.\\ ikeys+      rnodup = rkeys L.\\ ikeys+      lanno = concat $ map (maybeToList . flkup l) lnodup+      ranno = concat $ map (maybeToList . flkup r) rnodup+      ilanno = concat $ map (maybeToList . flkup l) ikeys+      iranno = concat $ map (maybeToList . flkup r) ikeys+      imps = zipWith M.union ilanno iranno+  in  M.fromList (zip lnodup lanno ++ zip rnodup ranno ++ zip ikeys imps)+
+ Yhc/Core/Extra.hs view
@@ -0,0 +1,28 @@+module Yhc.Core.Extra (module X, coreCtorMaybe, coreDataMaybe) where++import Yhc.Core as X++import Yhc.Core.MapNames as X+import Yhc.Core.Unreachable as X+import Yhc.Core.Annotation as X+import Yhc.Core.AnnotatePrims as X+import Yhc.Core.StrictAnno as X+import Yhc.Core.Selector as X++import Data.Maybe++-- |Non-crashing version of coreCtor++coreCtorMaybe :: Core -> CoreCtorName -> Maybe CoreCtor++coreCtorMaybe core name = listToMaybe +  [ctr | dat <- coreDatas core, ctr <- coreDataCtors dat, coreCtorName ctr == name]++-- |Non-crashing version of coreData++coreDataMaybe :: Core -> CoreDataName -> Maybe CoreData+coreDataMaybe core name = listToMaybe+  [dat | dat <- coreDatas core, coreDataName dat == name]+++
+ Yhc/Core/MapNames.hs view
@@ -0,0 +1,70 @@+------------------------------------------------------------------+-- |+-- Module      :  Yhc.Core.MapNames+-- Copyright   :  (c) Dmitry Golubovsky, 2007              +-- License     :  BSD-style+-- +-- Maintainer  :  golubovsky@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-- +--+--+-- Rename all functions and data constructors given a map of names+------------------------------------------------------------------++module Yhc.Core.MapNames (+  mapFunNames,+  mapDataNames,+  mapConNames) where++import Yhc.Core+import Data.Maybe+import qualified Data.Map as M++-- |Rename all functions in the Core given the map of old to new names.++mapFunNames :: M.Map CoreFuncName CoreFuncName -> Core -> Core++mapFunNames funmap core = mapFunDefs funmap $ mapUnderCore mapfun core where+  mapfun (CoreFun s) = let ns = M.lookup s funmap in CoreFun $ fromMaybe s ns+  mapfun z = z++mapFunDefs dmap core = core {coreFuncs = mpfd} where+  mpfd = map mpof $ coreFuncs core+  mpof func = let old = coreFuncName func+                  new = fromMaybe old $ M.lookup old dmap+              in  func {coreFuncName = new}+++-- |Rename all data objects (LHS of data XXX) given the map of old to new names.++mapDataNames :: M.Map CoreDataName CoreDataName -> Core -> Core++mapDataNames dmap core = core {coreDatas = mpdd} where+  mpdd = map mpod $ coreDatas core+  mpod dtdf = let old = coreDataName dtdf+                  new = fromMaybe old $ M.lookup old dmap+              in  dtdf {coreDataName = new}++-- |Rename all data constructors in the Core given the map of old to new names.++mapConNames :: M.Map CoreCtorName CoreCtorName -> Core -> Core++mapConNames conmap core = mapConDefs conmap $ mapUnderCore mapcon core where+  mapcon (CoreCon s) = let ns = M.lookup s conmap in CoreCon $ fromMaybe s ns+  mapcon (CoreCase expr alts) = CoreCase (mapcon expr) (map (mapalt conmap) alts) where +    mapalt conmap (altpat, altexpr) = (mappat conmap altpat, mapcon altexpr) where+      mappat conmap (PatCon s cvs) = +        let ns = M.lookup s conmap in PatCon (fromMaybe s ns) cvs+      mappat _ x = x+  mapcon z = z++mapConDefs cmap core = core {coreDatas = mpcd} where+  mpcd = map mapcons $ coreDatas core+  mapcons cdata = cdata {coreDataCtors = map mpod $ coreDataCtors cdata}+  mpod ctor = let old = coreCtorName ctor+                  new = fromMaybe old $ M.lookup old cmap+              in  ctor {coreCtorName = new}++
+ Yhc/Core/PrimAnnoRaw.hs view
@@ -0,0 +1,133 @@+-- Raw annotations for Core Normal Primitives (autogenerated, do not edit!!!)+module Yhc.Core.PrimAnnoRaw(rawPrimAnno) where++rawPrimAnno :: [[String]]+rawPrimAnno = [+  ["ADD_W","Y","Add two integer values","M","2","All","Int -> Int -> Int"],+  ["ADD_L","Y","Add two long integer values","ADD_W","2","All","Integer -> Integer -> Integer"],+  ["SUB_W","Y","Subtract two integer values","M","2","All","Int -> Int -> Int"],+  ["SUB_L","Y","Subtract two long integer values","SUB_W","2","All","Integer -> Integer -> Integer"],+  ["NEG_W","Y","Negate an integer value","M","1","All","Int -> Int"],+  ["NEG_L","Y","Negate a long integer value","NEG_W","1","All","Integer -> Integer"],+  ["EQ_W","Y","Compare two integer values for equality","M","2","All","Int -> Int -> Prelude;Bool"],+  ["EQ_L","Y","Compare two long integer values for equality","EQ_W","2","All","Integer -> Integer -> Prelude;Bool"],+  ["EQ_C","Y","Compare two characters for equality","M","2","All","Char -> Char -> Prelude;Bool"],+  ["NE_W","Y","Compare two integer values for non-equality","M","2","All","Int -> Int -> Prelude;Bool"],+  ["NE_L","Y","Compare two long integer values for non-equality","NE_W","2","All","Integer -> Integer -> Prelude;Bool"],+  ["LE_W","Y","Compare two integer values for less or equal","M","2","All","Int -> Int -> Prelude;Bool"],+  ["LE_L","Y","Compare two long integer values for less or equal","LE_W","2","All","Integer -> Integer -> Prelude;Bool"],+  ["LT_W","Y","Compare two integer values for less","M","2","All","Int -> Int -> Prelude;Bool"],+  ["LT_L","Y","Compare two long integer values for less","LT_W","2","All","Integer -> Integer -> Prelude;Bool"],+  ["GE_W","Y","Compare two integer values for greater or equal","M","2","All","Int -> Int -> Prelude;Bool"],+  ["GE_L","Y","Compare two long integer values for greater or equal","GE_W","2","All","Integer -> Integer -> Prelude;Bool"],+  ["GT_W","Y","Compare two integer values for greater","M","2","All","Int -> Int -> Prelude;Bool"],+  ["GT_L","Y","Compare two long integer values for greater","GT_W","2","All","Integer -> Integer -> Prelude;Bool"],+  ["CMP_W","Y","Compare two integer values","M","2","All","Int -> Int -> Prelude;Ordering"],+  ["CMP_L","Y","Compare two long integer values","CMP_W","2","All","Integer -> Integer -> Prelude;Ordering"],+  ["CMP_C","Y","Compare two characters","M","2","All","Char -> Char -> Prelude;Ordering"],+  ["CMP_T","Y","Compare two conctructor tags","M","2","All","a -> a -> Prelude;Ordering"],+  ["MUL_W","Y","Multiply two integer values","M","2","All","Int -> Int -> Int"],+  ["MUL_L","Y","Multiply two long integer values","MUL_W","2","All","Integer -> Integer -> Integer"],+  ["MOD_W","Y","Remainder of flooring integer division","M","2","All","Int -> Int -> Int"],+  ["MOD_L","Y","Remainder of flooring long integer division","MOD_W","2","All","Integer -> Integer -> Integer"],+  ["DIV_W","Y","Quotient of flooring integer division","M","2","All","Int -> Int -> Int"],+  ["DIV_L","Y","Quotient of flooring long integer division","DIV_W","2","All","Integer -> Integer -> Integer"],+  ["REM_W","Y","Remainder of trunc to zero integer division","M","2","All","Int -> Int -> Int"],+  ["REM_L","Y","Remainder of trunc to zero long integer division","REM_W","2","All","Integer -> Integer -> Integer"],+  ["QUOT_W","Y","Quotient of trunc to zero integer division","M","2","All","Int -> Int -> Int"],+  ["QUOT_L","Y","Quotient of trunc to zero long integer division","QUOT_W","2","All","Integer -> Integer -> Integer"],+  ["ADD_D","Y","Add two double precision values","M","2","All","Double -> Double -> Double"],+  ["ADD_F","Y","Add two floating point single precision values","ADD_D","2","All","Float -> Float -> Float"],+  ["SUB_D","Y","Subtract two double precision values","M","2","All","Double -> Double -> Double"],+  ["SUB_F","Y","Subtract two floating point single precision values","ADD_D","2","All","Float -> Float -> Float"],+  ["MUL_D","Y","Multiply two double precision values","M","2","All","Double -> Double -> Double"],+  ["MUL_F","Y","Multiply two floating point single precision values","ADD_D","2","All","Float -> Float -> Float"],+  ["DIV_D","Y","Divide two double precision values","M","2","All","Double -> Double -> Double"],+  ["DIV_F","Y","Divide two floating point single precision values","ADD_D","2","All","Float -> Float -> Float"],+  ["NEG_D","Y","Negate a double precision value","M","1","All","Float -> Float"],+  ["NEG_F","Y","Negate a floating point single precision value","NEG_D","1","All","Float -> Float"],+  ["ABS_W","Y","Absolute value of an integer","M","1","All","Int -> Int"],+  ["ABS_L","Y","Absolute value of a long integer","ABS_W","1","All","Integer -> Integer"],+  ["ABS_D","Y","Absolute value of a double precision ","M","1","All","Double -> Double"],+  ["ABS_F","Y","Absolute value of a floating","ABS_D","1","All","Float -> Float"],+  ["SIGNUM_W","Y","Sign of an integer","M","1","All","Int -> Int"],+  ["SIGNUM_L","Y","Sign of a long integer","SIGNUM_W","1","All","Integer -> Integer"],+  ["SIGNUM_D","Y","Sign of a double","M","1","All","Double -> Double"],+  ["SIGNUM_F","Y","Sign of a float","SIGNUM_D","1","All","Float -> Float"],+  ["LE_D","Y","Compare two double values for less or equal","M","2","All","Double -> Double -> Prelude;Bool"],+  ["LE_F","Y","Compare two floating values for less or equal","LE_D","2","All","Float -> Float -> Prelude;Bool"],+  ["LT_D","Y","Compare two double values for less","M","2","All","Double -> Double -> Prelude;Bool"],+  ["LT_F","Y","Compare two floating values for less","LT_D","2","All","Float -> Float -> Prelude;Bool"],+  ["GE_D","Y","Compare two double values for greater or equal","M","2","All","Double -> Double -> Prelude;Bool"],+  ["GE_F","Y","Compare two floating values for greater or equal","GE_D","2","All","Float -> Float -> Prelude;Bool"],+  ["GT_D","Y","Compare two double values for greater","M","2","All","Double -> Double -> Prelude;Bool"],+  ["GT_F","Y","Compare two floating values for greater","GT_D","2","All","Float -> Float -> Prelude;Bool"],+  ["EQ_D","Y","Compare two double values for equality","E [2]","2","All","Double -> Double -> Prelude;Bool"],+  ["EQ_F","Y","Compare two floating values for equality","E","2","All","Float -> Float -> Prelude;Bool"],+  ["NE_D","Y","Compare two double values for non-equality","E","2","All","Double -> Double -> Prelude;Bool"],+  ["NE_F","Y","Compare two floating values for non-equality","E","2","All","Float -> Float -> Prelude;Bool"],+  ["CMP_D","Y","Compare two double values","M","2","All","Double -> Double -> Prelude;Ordering"],+  ["CMP_F","Y","Compare two floating values","CMP_D","2","All","Float -> Float -> Prelude;Ordering"],+  ["CAST_LW","Y","Cast long integer to integer","M","1","All","Integer -> Int"],+  ["CAST_WL","Y","Cast integer to long integer","M","1","All","Int -> Integer"],+  ["CAST_WD","Y","Cast integer to double","M","1","All","Int -> Double"],+  ["CAST_WF","Y","Cast integer to float","CAST_WD","1","All","Int -> Float"],+  ["CAST_LD","Y","Cast long integer to double","CAST_WD","1","All","Integer -> Double"],+  ["CAST_LF","Y","Cast long integer to float","CAST_WD","1","All","Integer-> Float"],+  ["CAST_DF","Y","Cast double to float","M","1","All","Double -> Float"],+  ["CAST_RD","Y","Cast rational to double","M","1","All","Rational -> Double"],+  ["CAST_RF","Y","Cast rational to float","CAST_RD","1","All","Rational -> Float"],+  ["CAST_WC","Y","Cast integer to character","M","1","All","Int -> Char"],+  ["CAST_CW","Y","Cast character to integer","M","1","All","Char -> Int"],+  ["MAX_W","Y","Maximal value of an integer","M","0","None","Int"],+  ["MIN_W","Y","Minimal value of an integer","M","0","None","Int"],+  ["MAX_C","Y","Maximal value of a character","M","0","None","Char"],+  ["ISUPR_C","Y","Character in Unicode categories: Lu | Lt","M","1","All","Char -> Prelude;Bool"],+  ["ISLOW_C","Y","Character in Unicode categories: Ll","M","1","All","Char -> Prelude;Bool"],+  ["ISALP_C","Y","Character in Unicode categories: Lu | Ll | Lt | Lm | Lo","M","1","All","Char -> Prelude;Bool"],+  ["ISALN_C","Y","Character in Unicode categories: Lu through No","M","1","All","Char -> Prelude;Bool"],+  ["ISPRT_C","Y","Character in Unicode catrgories: Lu through Zs","M","1","All","Char -> Prelude;Bool"],+  ["TOUPR_C","Y","Change character case to upper","M","1","All","Char -> Char"],+  ["TOLOW_C","Y","Change character case to lower","M","1","All","Char -> Char"],+  ["TOTIT_C","Y","Change character case to title","TOUPR_C","1","All","Char -> Char"],+  ["UCAT_C","Y","Character Unicode category","M","1","All","Char -> Int"],+  ["SIN_F","Y","Sine of a float","M","1","All","Float -> Float"],+  ["COS_F","Y","Cosine of a float","M","1","All","Float -> Float"],+  ["TAN_F","Y","Tangent of a float","M","1","All","Float -> Float"],+  ["ASIN_F","Y","Arcsine of a float","M","1","All","Float -> Float"],+  ["ACOS_F","Y","Arccos. of a float","M","1","All","Float -> Float"],+  ["ATAN_F","Y","Arctan. of a float","M","1","All","Float -> Float"],+  ["EXP_F","Y","Exponent of a float","M","1","All","Float -> Float"],+  ["LOG_F","Y","Nat. logarithm of a float","M","1","All","Float -> Float"],+  ["SQRT_F","Y","Square root of a float","M","1","All","Float -> Float"],+  ["SIN_D","Y","Sine of a double","M","1","All","Double -> Double"],+  ["COS_D","Y","Cosine of a double","M","1","All","Double -> Double"],+  ["TAN_D","Y","Tangent of a double","M","1","All","Double -> Double"],+  ["ASIN_D","Y","Arcsine of a double","M","1","All","Double -> Double"],+  ["ACOS_D","Y","Arccos. of a double","M","1","All","Double -> Double"],+  ["ATAN_D","Y","Arctan. of a double","M","1","All","Double -> Double"],+  ["EXP_D","Y","Exponent of a double","M","1","All","Double -> Double"],+  ["LOG_D","Y","Nat. logarithm of a double","M","1","All","Double -> Double"],+  ["SQRT_D","Y","Square root of a double","M","1","All","Double -> Double"],+  ["RADIX_F","Y","Constant 2","M","0","","Int"],+  ["DIGITS_F","Y","Significant digits in a float","M","0","","Int"],+  ["MINEXP_F","Y","Minimal exponent of a float","M","0","","Int"],+  ["MAXEXP_F","Y","Maximal exponent of a float","M","0","","Int"],+  ["ENC_F","Y","Encode a float from significand and exponent","M","2","All","Integer -> Int -> Float"],+  ["DEC_F","Y","Decode a float into significand and exponent","M","1","All","Float -> (Integer, Int)"],+  ["DIGITS_D","Y","Significant digits in a double","M","0","","Int"],+  ["MINEXP_D","Y","Minimal exponent of a double","M","0","","Int"],+  ["MAXEXP_D","Y","Maximal exponent of a double","M","0","","Int"],+  ["ENC_D","Y","Encode a double from significand and exponent","M","2","All","Integer -> Int -> Double"],+  ["DEC_D","Y","Decode a double into significand and exponent","M","1","All","Double -> (Integer, Int)"],+  ["THROW_E","Y","Throw an exception","M","1","None","Exception -> a"],+  ["SEQ","Y","Evaluates its first argument to head normal form, and then returns its second argument as the result.","M","2","All","a -> b -> b"],+  ["QRM_W","Y","Combination of QUOT_W and REM_W","M","2","All","Int -> Int -> (Int, Int)"],+  ["QRM_L","Y","Combination of QUOT_L and REM_L","QRM_W","2","All","Integer -> Integer -> (Integer, Integer)"],+  ["STRICT_APP","Y","Strict application: always forces its argument","M","2","FT","(a -> b) -> a -> b"],+  ["SEL_ELEM","Y","Select an Nth element from a data structure","M","3","FTT","a -> b -> Int -> c"],+  ["SHOWS_W","Y","Show an Int value","O","3","All","Int -> a -> String -> String"],+  ["SHOWS_L","Y","Show and Integer value","SHOWS_W","3","All","Int -> a -> String -> String"],+  ["SHOWS_D","Y","Show a double value","M","3","All","Double -> a -> String -> String"],+  ["SHOWS_F","Y","Show a floating value","SHOWS_D","3","All","Float -> String -> String"]]+
+ Yhc/Core/Selector.hs view
@@ -0,0 +1,35 @@+module Yhc.Core.Selector (+  coreSelectorIndex) where++import Data.List+import Data.Maybe+import Yhc.Core++-- |Given an expr (normally a CoreApp)+--  tell if it is an application of a selector function+--  to a data object. Selector functions consist of a single+--  CoreCase statement with the only alternative. Application+--  must be exactly to one argument. The case alternative must+--  be a constructor application to field selectors, and +--  the return value must be one of the selectors.+--  If the analysis condition is satisfied, constructor name and+--  a field index are returned. Otherwise empty string and -1 are returned.+--  The index returned is zero-based.++coreSelectorIndex :: Core -> CoreFuncName -> (CoreCtorName, Int)++coreSelectorIndex core fn = x+  where+    nosel = ("", -1)+    unpos (CorePos _ e) = unpos e+    unpos e = e+    x = case coreFuncMaybe core fn of+      (Just func@CoreFunc {coreFuncArgs = (a:[])}) -> +        case unpos (coreFuncBody func) of+          CoreCase _ [(PatCon con sels, (CoreVar ce))] ->+            case fromMaybe (-1) (elemIndex ce sels) of +              (-1) -> nosel+              n    -> (con, n)+          _ -> nosel+      _ -> nosel+
+ Yhc/Core/StrictAnno.hs view
@@ -0,0 +1,87 @@+-- Version of the Yhc.Core.Strictness module, but based on+-- Core Annotations.++module Yhc.Core.StrictAnno (+  coreStrictAnno) where++import Yhc.Core.Type+import Yhc.Core.Prim+import Yhc.Core.Annotation+import Yhc.Core.AnnotatePrims++import qualified Data.Map as Map+import Data.List(intersect, nub, partition)++{-+ALGORITHM:++SCC PARTIAL SORT:+First sort the functions so that they occur in the childmost order:+x1 < x2, if x1 doesn't transitive-call x2, and x2 does transitive-call x1+Being wrong is fine, but being better gives better results++PRIM STRICTNESS:+The strictness of the various primitive operations++BASE STRICTNESS:+If all paths case on a particular value, then these are strict in that one+If call onwards, then strict based on the caller+-}+++-- | Given a function, return a list of arguments.+--   True is strict in that argument, False is not.+--   [] is unknown strictness+--++coreStrictAnno :: CoreAnnotations -> Core -> (CoreFuncName -> [Bool])++coreStrictAnno anno core = \funcname -> Map.findWithDefault [] funcname mp+    where mp = mapStrictAnno anno $ sccSort $ coreFuncs core+++mapStrictAnno anno funcs = foldl f Map.empty funcs+    where+        f mp (prim@CorePrim{coreFuncName = name}) = +          case getAnnotation prim "Strictness" anno of+            Nothing -> mp+            Just (CoreStrictness bs) -> Map.insert name bs mp++        f mp func@(CoreFunc name args body) = case getAnnotation func "Strictness" anno of+          Just (CoreStrictness bs) -> Map.insert name bs mp+          Nothing -> Map.insert name (map (`elem` strict) args) mp+            where+                strict = strictVars body++                -- which variables are strict+                strictVars :: CoreExpr -> [String]+                strictVars (CorePos _ x) = strictVars x+                strictVars (CoreVar x) = [x]++                strictVars (CoreCase (CoreVar x) alts) = +                  nub $ x : intersectList (map (strictVars . snd) alts)++                strictVars (CoreCase x alts) = strictVars x++                strictVars (CoreApp (CoreFun x) xs)+                    | length xs == length res+                    = nub $ concatMap strictVars $ map snd $ filter fst $ zip res xs+                    where res = Map.findWithDefault [] x mp++                strictVars (CoreApp x xs) = strictVars x++                strictVars _ = []+++++intersectList :: Eq a => [[a]] -> [a]+intersectList [] = []+intersectList xs = foldr1 intersect xs+++-- do a sort in approximate SCC order+sccSort :: [CoreFunc] -> [CoreFunc]+sccSort xs = prims ++ funcs+    where (prims,funcs) = partition isCorePrim xs+
+ Yhc/Core/Unreachable.hs view
@@ -0,0 +1,43 @@+-- Unreachability++module Yhc.Core.Unreachable (+-- *Unreachability+-- $unreach+   coreUnreachableFuncs+  ,coreUnreachableDatas) where++import Yhc.Core+import qualified Data.Set as S++-- $unreach 'Yhc.Core.Reachable.coreReachable' fails if any of the+-- function\/constructor calls cannot be matched by a function defined in the+-- linked Core. The two functions provided in this module help detect+-- missing (in other words, unreachable) functions to give user alerts,+-- or to automatically create some missing items where possible.++-- |Determine missing (unreachable) functions.+--  /All functions called/ except /All functions defined/+++coreUnreachableFuncs :: Core -> [CoreFuncName]++coreUnreachableFuncs core =+  let cfuns = coreFuncs core+      calledBy fn = [f | CoreFun f <- universeExpr fn]+      called = foldl (flip S.insert) S.empty (concat $ map calledBy cfuns)+      defined = S.fromList (map coreFuncName cfuns)+  in  S.toList (called S.\\ defined)++-- |Determine missing (unreachable) data constructors.+-- /All ctors called\/used in patterns/ except /All ctors defined/++coreUnreachableDatas :: Core -> [CoreCtorName]++coreUnreachableDatas core =+  let called = S.fromList $ [x | CoreCon x <- universeExpr core] +++              [x | CoreCase _ alts <- universeExpr core, (PatCon x _,_) <- alts]+      defined = S.fromList $ map coreCtorName $ +                             concat $ map coreDataCtors $ coreDatas core+  in S.toList (called S.\\ defined)++
+ configure view
@@ -0,0 +1,10 @@+#!/bin/sh++# This shell script is not related to GNU Autoconf.+# It will be run by the Cabal Setup program during the configuration phase.+# Cabal Setup program for this package uses defaultMainWithHooks.++exec runhugs    csvprim/GenPrimTable.hs csvprim/20081121.csv \+                Yhc/Core/PrimAnnoRaw.hs \+		Yhc.Core.PrimAnnoRaw+
+ csvprim/20080629.csv view
@@ -0,0 +1,111 @@+Primitive Name,Use Row,Primitive Semantics,Status [1],Arity,Strictness,Type Signature,Front-End Mappings+,,,,,,,Yhc,Hugs,GHC+,,Arithmetic Primitives+ADD_W,Y,Add two integer values,M,2,All,Int -> Int -> Int,ADD_W,Prelude;primPlusInt+ADD_L,Y,Add two long integer values,ADD_W,2,All,Integer -> Integer -> Integer,YHC.Primitive;PrimIntegerAdd,Prelude;primPlusInteger+SUB_W,Y,Subtract two integer values,M,2,All,Int -> Int -> Int,SUB_W,Prelude;primMinusInt+SUB_L,Y,Subtract two long integer values,SUB_W,2,All,Integer -> Integer -> Integer,YHC.Primitive;PrimIntegerSub,Prelude;primMinusInteger+NEG_W,Y,Negate an integer value,M,1,All,Int -> Int,NEG_W,Prelude;primNegInt+NEG_L,Y,Negate a long integer value,NEG_W,1,All,Integer -> Integer,YHC.Primitive;PrimIntegerNeg,Prelude;primNegInteger+EQ_W,Y,Compare two integer values for equality,M,2,All,Int -> Int -> Bool,EQ_W,Prelude;primEqInt+EQ_L,Y,Compare two long integer values for equality,EQ_W,2,All,Integer -> Integer -> Bool,YHC.Primitive;primIntegerEq,Prelude;primEqInteger+NE_W,Y,Compare two integer values for non-equality,M,2,All,Int -> Int -> Bool,NE_W+NE_L,Y,Compare two long integer values for non-equality,NE_W,2,All,Integer -> Integer -> Bool,YHC.Primitive;primIntegerNe+LE_W,Y,Compare two integer values for less or equal,M,2,All,Int -> Int -> Bool,LE_W+LE_L,Y,Compare two long integer values for less or equal,LE_W,2,All,Integer -> Integer -> Bool,YHC.Primitive;primIntegerLe+LT_W,Y,Compare two integer values for less,M,2,All,Int -> Int -> Bool,LT_W+LT_L,Y,Compare two long integer values for less,LT_W,2,All,Integer -> Integer -> Bool,YHC.Primitive;primIntegerLt+GE_W,Y,Compare two integer values for greater or equal,M,2,All,Int -> Int -> Bool,GE_W+GE_L,Y,Compare two long integer values for greater or equal,GE_W,2,All,Integer -> Integer -> Bool,YHC.Primitive;primIntegerGe+GT_W,Y,Compare two integer values for greater,M,2,All,Int -> Int -> Bool,GT_W+GT_L,Y,Compare two long integer values for greater,GT_W,2,All,Integer -> Integer -> Bool,YHC.Primitive;primIntegerGt+CMP_W,Y,Compare two integer values,M,2,All,Int -> Int -> Ordering,,Prelude;primCmpInt+CMP_L,Y,Compare two long integer values,CMP_W,2,All,Integer -> Integer -> Ordering,,Prelude;primCmpInteger+MUL_W,Y,Multiply two integer values,M,2,All,Int -> Int -> Int,MUL_W,Prelude;primMulInt+MUL_L,Y,Multiply two long integer values,MUL_W,2,All,Integer -> Integer -> Integer,YHC.Primitive;PrimIntegerMul,Prelude;primMulInteger+MOD_W,Y,Remainder of flooring integer division,M,2,All,Int -> Int -> Int+MOD_L,Y,Remainder of flooring long integer division,MOD_W,2,All,Integer -> Integer -> Integer+DIV_W,Y,Quotient of flooring integer division,M,2,All,Int -> Int -> Int+DIV_L,Y,Quotient of flooring long integer division,DIV_W,2,All,Integer -> Integer -> Integer+REM_W,Y,Remainder of trunc to zero integer division,M,2,All,Int -> Int -> Int+REM_L,Y,Remainder of trunc to zero long integer division,REM_W,2,All,Integer -> Integer -> Integer+QUOT_W,Y,Quotient of trunc to zero integer division,M,2,All,Int -> Int -> Int+QUOT_L,Y,Quotient of trunc to zero long integer division,QUOT_W,2,All,Integer -> Integer -> Integer+ADD_D,Y,Add two double precision values,M,2,All,Double -> Double -> Double,ADD_D,Prelude;primPlusDouble+ADD_F,Y,Add two floating point single precision values,ADD_D,2,All,Float -> Float -> Float,ADD_F,Prelude;primPlusFloat+ADD_D,Y,Subtract two double precision values,M,2,All,Double -> Double -> Double,SUB_D,Prelude;primMinusDouble+SUB_F,Y,Subtract two floating point single precision values,ADD_D,2,All,Float -> Float -> Float,SUB_F,Prelude;primMinusFloat+MUL_D,Y,Multiply two double precision values,M,2,All,Double -> Double -> Double,MUL_D,Prelude;primMulDouble+MUL_F,Y,Multiply two floating point single precision values,ADD_D,2,All,Float -> Float -> Float,MUL_F,Prelude;primMulFloat+DIV_D,Y,Divide two double precision values,M,2,All,Double -> Double -> Double,SLASH_D,Prelude;primDivDouble+DIV_F,Y,Divide two floating point single precision values,ADD_D,2,All,Float -> Float -> Float,SLASH_F,Prelude;primDivFloat+NEG_D,Y,Negate a double precision value,M,1,All,Float -> Float,NEG_D,Prelude;primNegDouble+NEG_F,Y,Negate a floating point single precision value,NEG_D,1,All,Float -> Float,NEG_F,Prelude;primNegFloat+ABS_W,Y,Absolute value of an integer,M,1,All,Int -> Int,YHC.Primitive;primIntAbs+ABS_L,Y,Absolute value of a long integer,ABS_W,1,All,Integer -> Integer+ABS_D,Y,Absolute value of a double precision ,M,1,All,Double -> Double+ABS_F,Y,Absolute value of a floating,ABS_D,1,All,Float -> Float+SIGNUM_W,Y,Sign of an integer,M,1,All,Int -> Int,YHC.Primitive;primIntSignum+SIGNUM_L,Y,Sign of a long integer,SIGNUM_W,1,All,Integer -> Integer+SIGNUM_D,Y,Sign of a double,M,1,All,Double -> Double+SIGNUM_F,Y,Sign of a float,SIGNUM_D,1,All,Float -> Float+LE_D,Y,Compare two double values for less or equal,M,2,All,Double -> Double -> Bool,LE_D+LE_F,Y,Compare two floating values for less or equal,LE_D,2,All,Float -> Float -> Bool,LE_F+LT_D,Y,Compare two double values for less,M,2,All,Double -> Double -> Bool,LT_D+LT_F,Y,Compare two floating values for less,LT_D,2,All,Float -> Float -> Bool,LT_F+GE_D,Y,Compare two double values for greater or equal,M,2,All,Double -> Double -> Bool,GE_D+GE_F,Y,Compare two floating values for greater or equal,GE_D,2,All,Float -> Float -> Bool,GE_F+GT_D,Y,Compare two double values for greater,M,2,All,Double -> Double -> Bool,GT_D+GT_F,Y,Compare two floating values for greater,GT_D,2,All,Float -> Float -> Bool,GT_F+EQ_D,Y,Compare two double values for equality,E [2],2,All,Double -> Double -> Bool,EQ_D+EQ_F,Y,Compare two floating values for equality,E,2,All,Float -> Float -> Bool,EQ_F+NE_D,Y,Compare two double values for non-equality,E,2,All,Double -> Double -> Bool,EQ_D+NE_F,Y,Compare two floating values for non-equality,E,2,All,Float -> Float -> Bool,EQ_F+CMP_D,Y,Compare two double values,M,2,All,Double -> Double -> Ordering,,Prelude;primCmpDouble+CMP_F,Y,Compare two floating values,CMP_D,2,All,Float -> Float -> Ordering,,Prelude;primCmpFloat+CAST_LW,Y,Cast long integer to integer,M,1,All,Integer -> Int,YHC.Primitive;primIntFromInteger,Prelude;primIntegerToInt+CAST_WL,Y,Cast integer to long integer,M,1,All,Int -> Integer,YHC.Primitive;primIntegerFromInt,Prelude;primIntToInteger+CAST_LD,Y,Cast long integer to double,M,1,All,Integer -> Double,YHC.Primitive;primDoubleFromInteger,Prelude;primIntegerToDouble+,,Character/Unicode Primitives+MAX_C,Y,Maximal value of a character,M,0,None,Char,,Prelude;primMaxChar+ISUPR_C,Y,Character in Unicode categories: Lu | Lt,M,1,All,Char -> Bool,,Prelude;primIsUpper+ISLOW_C,Y,Character in Unicode categories: Ll,M,1,All,Char -> Bool,,Prelude;primIsLower+ISALP_C,Y,Character in Unicode categories: Lu | Ll | Lt | Lm | Lo,M,1,All,Char -> Bool,,Prelude;primIsAlpha+ISALN_C,Y,Character in Unicode categories: Lu through No,M,1,All,Char -> Bool,,Prelude;primIsAlphaNum+ISPRT_C,Y,Character in Unicode catrgories: Lu through Zs,M,1,All,Char -> Bool,,Prelude;isPrint+TOUPR_C,Y,Change character case to upper,M,1,All,Char -> Char,,Prelude;toUpper+TOLOW_C,Y,Change character case to lower,M,1,All,Char -> Char,,Prelude;toLower+TOTIT_C,Y,Change character case to title,TOUPR_C,1,All,Char -> Char,,Hugs.Char;toTitle+UCAT_C,Y,Character Unicode category,M,1,All,Char -> Int,,Hugs.Char;primUniGenCat+,,Math/Floating point Primitives+SIN_F,Y,Sine of a float,M,1,All,Float -> Float,,Prelude;primSinFloat+COS_F,Y,Cosine of a float,M,1,All,Float -> Float,,Prelude;primCosFloat+TAN_F,Y,Tangent of a float,M,1,All,Float -> Float,,Prelude;primTanFloat+ASIN_F,Y,Arcsine of a float,M,1,All,Float -> Float,,Prelude;primAsinFloat+ACOS_F,Y,Arccos. of a float,M,1,All,Float -> Float,,Prelude;primAcosFloat+ATAN_F,Y,Arctan. of a float,M,1,All,Float -> Float,,Prelude;primAtanFloat+EXP_F,Y,Exponent of a float,M,1,All,Float -> Float,,Prelude;primExpFloat+LOG_F,Y,Nat. logarithm of a float,M,1,All,Float -> Float,,Prelude;primLogFloat+SQRT_F,Y,Square root of a float,M,1,All,Float -> Float,,Prelude;primSqrtFloat+SIN_D,Y,Sine of a double,M,1,All,Double -> Double,,Prelude;primSinDouble+COS_D,Y,Cosine of a double,M,1,All,Double -> Double,,Prelude;primCosDouble+TAN_D,Y,Tangent of a double,M,1,All,Double -> Double,,Prelude;primTanDouble+ASIN_D,Y,Arcsine of a double,M,1,All,Double -> Double,,Prelude;primAsinDouble+ACOS_D,Y,Arccos. of a double,M,1,All,Double -> Double,,Prelude;primAcosDouble+ATAN_D,Y,Arctan. of a double,M,1,All,Double -> Double,,Prelude;primAtanDouble+EXP_D,Y,Exponent of a double,M,1,All,Double -> Double,,Prelude;primExpDouble+LOG_D,Y,Nat. logarithm of a double,M,1,All,Double -> Double,,Prelude;primLogDouble+SQRT_D,Y,Square root of a double,M,1,All,Double -> Double,,Prelude;primSqrtDouble+RADIX_F,Y,Constant 2,M,0,,Int,,"Prelude;primFloatRadix, Prelude;primDoubleRadix"+DIGITS_F,Y,Significant digits in a float,M,0,,Int,,Prelude;primFloatDigits+MINEXP_F,Y,Minimal exponent of a float,M,0,,Int,,Prelude;primFloatMinExp+MAXEXP_F,Y,Maximal exponent of a float,M,0,,Int,,Prelude;primFloatMaxExp+ENC_F,Y,Encode a float from significand and exponent,M,2,All,Integer -> Int -> Float,,Prelude;primFloatEncode+DEC_F,Y,Decode a float into significand and exponent,M,1,All,"Float -> (Integer, Int)",,Prelude;primFloatDecode+DIGITS_D,Y,Significant digits in a double,M,0,,Int,,Prelude;primDoubleDigits+MINEXP_D,Y,Minimal exponent of a double,M,0,,Int,,Prelude;primDoubleMinExp+MAXEXP_D,Y,Maximal exponent of a double,M,0,,Int,,Prelude;primDoubleMaxExp+ENC_D,Y,Encode a double from significand and exponent,M,2,All,Integer -> Int -> Double,,Prelude;primDoubleEncode+DEC_D,Y,Decode a double into significand and exponent,M,1,All,"Double -> (Integer, Int)",,Prelude;primDoubleDecode++
+ csvprim/GenPrimTable.hs view
@@ -0,0 +1,67 @@+-- A configure-time tool to build annotations for normal+-- Core primitives from the CSV file obtained from the Google+-- Spreadsheet that is maintained by the Yhc Core Team+-- and contains the source of normal primitives annotation.+-- Whether runhugs or runghc runs this program, the `csv'+-- package should be properly installed and visible.++-- CSV record format is (7 fields):+-- [0]:  primitive name+-- [1]: "Y" if this record is usable+-- [2]: primitive description+-- [3]: implementation mandatory ("M") or can be substituted with <primitive name>+-- [4]: arity+-- [5]: strictness (All | [TF]* | "")+-- [6]: type signature++module Main where++import System.Environment+import System.Directory+import System.FilePath+import System.Exit+import System.IO+import Control.Monad+import Data.List+import Text.CSV++main = do+  args <- getArgs+  prog <- getProgName+  cd <- getCurrentDirectory+  when (length args < 3) $ do+    hPutStrLn stderr $ prog ++ ": three arguments needed"+    exitWith (ExitFailure 1)+  let [csv, outf] = map (cd </>) (take 2 args)+      outmod = head (drop 2 args)+  putStrLn $ prog ++ ": converting \n  from: " ++ csv ++ +                     "\n  to:   " ++ outf +++                     "\n  as:   " ++ outmod+  csvrecs <- parseCSVFromFile csv >>= return . +                                      map (take 7) . +                                      filter usable .+                                      either (\e -> error $ show e) id+  hout <- openFile outf WriteMode+  mapM (hPutStrLn hout) (modHeader outmod)+  hPutStrLn hout "rawPrimAnno :: [[String]]"+  hPutStrLn hout "rawPrimAnno = ["+  let inddef = map (("  " ++) . show) csvrecs+      catdef = concat $ intersperse ",\n" inddef+  hPutStrLn hout $ catdef ++ "]\n"+  hClose hout+  putStrLn $ prog ++ ": done"++-- Autogenerated module header (based on the module name provided)++modHeader md = [+  "-- Raw annotations for Core Normal Primitives (autogenerated, do not edit!!!)"+ ,"module " ++ md ++ "(rawPrimAnno) where\n"]++-- Filter records based on the condition that number of elements in a record+-- is at least 7, and the second element is "Y".++usable :: [Field] -> Bool++usable rec@(_: "Y": _) = length rec >= 7+usable _ = False+
+ ycextra.cabal view
@@ -0,0 +1,37 @@+Cabal-Version:      >= 1.2+Name:               ycextra+Version:            0.1+Copyright:          2008, Dmitry Golubovsky and The Yhc Team+Maintainer:         golubovsky@gmail.com+Homepage:           http://www.haskell.org/haskellwiki/Yhc+License:            BSD3+License-File:       LICENSE+Build-Type:         Simple+Data-Files:         configure, csvprim/GenPrimTable.hs+                    csvprim/20080629.csv+Author:             Dmitry Golubovsky+Synopsis:           Additional utilities to work with Yhc Core.+Description:+    Additional utilities for Yhc Core developed as by-products+    of front- and back-ends, also for possible inclusion +    to the Yhc Core package.+Category:           Development++Flag splitBase+    Description: Choose the new smaller, split-up base package.++Library+    if flag(splitBase)+        build-depends: base >= 3, mtl, containers+    else+        build-depends: base < 3, mtl+    build-depends: mtl, uniplate, yhccore, csv++    Exposed-modules:+        Yhc.Core.Extra, Yhc.Core.AnnotatePrims, Yhc.Core.StrictAnno+        Yhc.Core.Unreachable, Yhc.Core.MapNames, Yhc.Core.Annotation,+        Yhc.Core.Selector+    Other-modules:+        Yhc.Core.PrimAnnoRaw++